packages feed

ghc-lib 0.20200102 → 0.20200201

raw patch · 322 files changed

+45819/−52246 lines, 322 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

+ compiler/GHC/Cmm/CallConv.hs view
@@ -0,0 +1,212 @@+module GHC.Cmm.CallConv (+  ParamLocation(..),+  assignArgumentsPos,+  assignStack,+  realArgRegsCover+) where++import GhcPrelude++import GHC.Cmm.Expr+import GHC.Runtime.Layout+import GHC.Cmm (Convention(..))+import GHC.Cmm.Ppr () -- For Outputable instances++import DynFlags+import GHC.Platform+import Outputable++-- Calculate the 'GlobalReg' or stack locations for function call+-- parameters as used by the Cmm calling convention.++data ParamLocation+  = RegisterParam GlobalReg+  | StackParam ByteOff++instance Outputable ParamLocation where+  ppr (RegisterParam g) = ppr g+  ppr (StackParam p)    = ppr p++-- |+-- Given a list of arguments, and a function that tells their types,+-- return a list showing where each argument is passed+--+assignArgumentsPos :: DynFlags+                   -> ByteOff           -- stack offset to start with+                   -> Convention+                   -> (a -> CmmType)    -- how to get a type from an arg+                   -> [a]               -- args+                   -> (+                        ByteOff              -- bytes of stack args+                      , [(a, ParamLocation)] -- args and locations+                      )++assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)+    where+      regs = case (reps, conv) of+               (_,   NativeNodeCall)   -> getRegsWithNode dflags+               (_,   NativeDirectCall) -> getRegsWithoutNode dflags+               ([_], NativeReturn)     -> allRegs dflags+               (_,   NativeReturn)     -> getRegsWithNode dflags+               -- GC calling convention *must* put values in registers+               (_,   GC)               -> allRegs dflags+               (_,   Slow)             -> nodeOnly+      -- The calling conventions first assign arguments to registers,+      -- then switch to the stack when we first run out of registers+      -- (even if there are still available registers for args of a+      -- different type).  When returning an unboxed tuple, we also+      -- separate the stack arguments by pointerhood.+      (reg_assts, stk_args)  = assign_regs [] reps regs+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args+      assignments = reg_assts ++ stk_assts++      assign_regs assts []     _    = (assts, [])+      assign_regs assts (r:rs) regs | isVecType ty   = vec+                                    | isFloatType ty = float+                                    | otherwise      = int+        where vec = case (w, regs) of+                      (W128, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))+                      (W256, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))+                      (W512, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))+                      _ -> (assts, (r:rs))+              float = case (w, regs) of+                        (W32, (vs, fs, ds, ls, s:ss))+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))+                        (W32, (vs, f:fs, ds, ls, ss))+                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))+                        (W64, (vs, fs, ds, ls, s:ss))+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))+                        (W64, (vs, fs, d:ds, ls, ss))+                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))+                        _ -> (assts, (r:rs))+              int = case (w, regs) of+                      (W128, _) -> panic "W128 unsupported register type"+                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)+                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))+                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)+                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))+                      _   -> (assts, (r:rs))+              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'+              ty = arg_ty r+              w  = typeWidth ty+              gcp | isGcPtrType ty = VGcPtr+                  | otherwise      = VNonGcPtr+              passFloatInXmm = passFloatArgsInXmm dflags++passFloatArgsInXmm :: DynFlags -> Bool+passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of+                              ArchX86_64 -> True+                              ArchX86    -> False+                              _          -> False++-- We used to spill vector registers to the stack since the LLVM backend didn't+-- support vector registers in its calling convention. However, this has now+-- been fixed. This function remains only as a convenient way to re-enable+-- spilling when debugging code generation.+passVectorInReg :: Width -> DynFlags -> Bool+passVectorInReg _ _ = True++assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]+            -> (+                 ByteOff              -- bytes of stack args+               , [(a, ParamLocation)] -- args and locations+               )+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)+ where+      assign_stk offset assts [] = (offset, assts)+      assign_stk offset assts (r:rs)+        = assign_stk off' ((r, StackParam off') : assts) rs+        where w    = typeWidth (arg_ty r)+              off' = offset + size+              -- Stack arguments always take a whole number of words, we never+              -- pack them unlike constructor fields.+              size = roundUpToWords dflags (widthInBytes w)++-----------------------------------------------------------------------------+-- Local information about the registers available++type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.+                 , [GlobalReg]   -- floats+                 , [GlobalReg]   -- doubles+                 , [GlobalReg]   -- longs (int64 and word64)+                 , [Int]         -- XMM (floats and doubles)+                 )++-- Vanilla registers can contain pointers, Ints, Chars.+-- Floats and doubles have separate register supplies.+--+-- We take these register supplies from the *real* registers, i.e. those+-- that are guaranteed to map to machine registers.++getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs+getRegsWithoutNode dflags =+  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)+  , realFloatRegs dflags+  , realDoubleRegs dflags+  , realLongRegs dflags+  , realXmmRegNos dflags)++-- getRegsWithNode uses R1/node even if it isn't a register+getRegsWithNode dflags =+  ( if null (realVanillaRegs dflags)+    then [VanillaReg 1]+    else realVanillaRegs dflags+  , realFloatRegs dflags+  , realDoubleRegs dflags+  , realLongRegs dflags+  , realXmmRegNos dflags)++allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]+allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]+allXmmRegs :: DynFlags -> [Int]++allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)+allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)+allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)+allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)+allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)++realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]+realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]+realXmmRegNos :: DynFlags -> [Int]++realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)+realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)+realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)+realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)++realXmmRegNos dflags+    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)+    | otherwise            = []++regList :: Int -> [Int]+regList n = [1 .. n]++allRegs :: DynFlags -> AvailRegs+allRegs dflags = (allVanillaRegs dflags,+                  allFloatRegs dflags,+                  allDoubleRegs dflags,+                  allLongRegs dflags,+                  allXmmRegs dflags)++nodeOnly :: AvailRegs+nodeOnly = ([VanillaReg 1], [], [], [], [])++-- This returns the set of global registers that *cover* the machine registers+-- used for argument passing. On platforms where registers can overlap---right+-- now just x86-64, where Float and Double registers overlap---passing this set+-- of registers is guaranteed to preserve the contents of all live registers. We+-- only use this functionality in hand-written C-- code in the RTS.+realArgRegsCover :: DynFlags -> [GlobalReg]+realArgRegsCover dflags+    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) +++                                  realLongRegs dflags +++                                  map XmmReg (realXmmRegNos dflags)+    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) +++                                  realFloatRegs dflags +++                                  realDoubleRegs dflags +++                                  realLongRegs dflags +++                                  map XmmReg (realXmmRegNos dflags)
+ compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}++module GHC.Cmm.CommonBlockElim+  ( elimCommonBlocks+  )+where+++import GhcPrelude hiding (iterate, succ, unzip, zip)++import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch (eqSwitchTargetWith)+import GHC.Cmm.ContFlowOpt++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Collections+import Data.Bits+import Data.Maybe (mapMaybe)+import qualified Data.List as List+import Data.Word+import qualified Data.Map as M+import Outputable+import qualified TrieMap as TM+import UniqFM+import Unique+import Control.Arrow (first, second)++-- -----------------------------------------------------------------------------+-- Eliminate common blocks++-- If two blocks are identical except for the label on the first node,+-- then we can eliminate one of the blocks. To ensure that the semantics+-- of the program are preserved, we have to rewrite each predecessor of the+-- eliminated block to proceed with the block we keep.++-- The algorithm iterates over the blocks in the graph,+-- checking whether it has seen another block that is equal modulo labels.+-- If so, then it adds an entry in a map indicating that the new block+-- is made redundant by the old block.+-- Otherwise, it is added to the useful blocks.++-- To avoid comparing every block with every other block repeatedly, we group+-- them by+--   * a hash of the block, ignoring labels (explained below)+--   * the list of outgoing labels+-- The hash is invariant under relabeling, so we only ever compare within+-- the same group of blocks.+--+-- The list of outgoing labels is updated as we merge blocks (that is why they+-- are not included in the hash, which we want to calculate only once).+--+-- All in all, two blocks should never be compared if they have different+-- hashes, and at most once otherwise. Previously, we were slower, and people+-- rightfully complained: #10397++-- TODO: Use optimization fuel+elimCommonBlocks :: CmmGraph -> CmmGraph+elimCommonBlocks g = replaceLabels env $ copyTicks env g+  where+     env = iterate mapEmpty blocks_with_key+     -- The order of blocks doesn't matter here. While we could use+     -- revPostorder which drops unreachable blocks this is done in+     -- ContFlowOpt already which runs before this pass. So we use+     -- toBlockList since it is faster.+     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]++-- Invariant: The blocks in the list are pairwise distinct+-- (so avoid comparing them again)+type DistinctBlocks = [CmmBlock]+type Key = [Label]+type Subst = LabelMap BlockId++-- The outer list groups by hash. We retain this grouping throughout.+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst+iterate subst blocks+    | mapNull new_substs = subst+    | otherwise = iterate subst' updated_blocks+  where+    grouped_blocks :: [[(Key, [DistinctBlocks])]]+    grouped_blocks = map groupByLabel blocks++    merged_blocks :: [[(Key, DistinctBlocks)]]+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks+      where+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))+          where+            (new_subst2, db) = mergeBlockList subst dbs++    subst' = subst `mapUnion` new_substs+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks++-- Combine two lists of blocks.+-- While they are internally distinct they can still share common blocks.+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)+mergeBlocks subst existing new = go new+  where+    go [] = (mapEmpty, existing)+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of+        -- This block is a duplicate. Drop it, and add it to the substitution+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs+        -- This block is not a duplicate, keep it.+        Nothing -> second (b:) $ go bs++mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)+mergeBlockList _ [] = pprPanic "mergeBlockList" empty+mergeBlockList subst (b:bs) = go mapEmpty b bs+  where+    go !new_subst1 b [] = (new_subst1, b)+    go !new_subst1 b1 (b2:bs) = go new_subst b bs+      where+        (new_subst2, b) =  mergeBlocks subst b1 b2+        new_subst = new_subst1 `mapUnion` new_subst2+++-- -----------------------------------------------------------------------------+-- Hashing and equality on blocks++-- Below here is mostly boilerplate: hashing blocks ignoring labels,+-- and comparing blocks modulo a label mapping.++-- To speed up comparisons, we hash each basic block modulo jump labels.+-- The hashing is a bit arbitrary (the numbers are completely arbitrary),+-- but it should be fast and good enough.++-- We want to get as many small buckets as possible, as comparing blocks is+-- expensive. So include as much as possible in the hash. Ideally everything+-- that is compared with (==) in eqBlockBodyWith.++type HashCode = Int++hash_block :: CmmBlock -> HashCode+hash_block block =+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))+  -- UniqFM doesn't like negative Ints+  where hash_fst _ h = h+        hash_mid m h = hash_node m + h `shiftL` 1+        hash_lst m h = hash_node m + h `shiftL` 1++        hash_node :: CmmNode O x -> Word32+        hash_node n | dont_care n = 0 -- don't care+        hash_node (CmmAssign r e) = hash_reg r + hash_e e+        hash_node (CmmStore e e') = hash_e e + hash_e e'+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as+        hash_node (CmmBranch _) = 23 -- NB. ignore the label+        hash_node (CmmCondBranch p _ _ _) = hash_e p+        hash_node (CmmCall e _ _ _ _ _) = hash_e e+        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t+        hash_node (CmmSwitch e _) = hash_e e+        hash_node _ = error "hash_node: unknown Cmm node!"++        hash_reg :: CmmReg -> Word32+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397+        hash_reg   (CmmGlobal _)    = 19++        hash_e :: CmmExpr -> Word32+        hash_e (CmmLit l) = hash_lit l+        hash_e (CmmLoad e _) = 67 + hash_e e+        hash_e (CmmReg r) = hash_reg r+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check+        hash_e (CmmRegOff r i) = hash_reg r + cvt i+        hash_e (CmmStackSlot _ _) = 13++        hash_lit :: CmmLit -> Word32+        hash_lit (CmmInt i _) = fromInteger i+        hash_lit (CmmFloat r _) = truncate r+        hash_lit (CmmVec ls) = hash_list hash_lit ls+        hash_lit (CmmLabel _) = 119 -- ugh+        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i+        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i+        hash_lit (CmmBlock _) = 191 -- ugh+        hash_lit (CmmHighStackMark) = cvt 313++        hash_tgt (ForeignTarget e _) = hash_e e+        hash_tgt (PrimTarget _) = 31 -- lots of these++        hash_list f = foldl' (\z x -> f x + z) (0::Word32)++        cvt = fromInteger . toInteger++        hash_unique :: Uniquable a => a -> Word32+        hash_unique = cvt . getKey . getUnique++-- | Ignore these node types for equality+dont_care :: CmmNode O x -> Bool+dont_care CmmComment {}  = True+dont_care CmmTick {}     = True+dont_care CmmUnwind {}   = True+dont_care _other         = False++-- Utilities: equality and substitution on the graph.++-- Given a map ``subst'' from BlockID -> BlockID, we define equality.+eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool+eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'+lookupBid :: LabelMap BlockId -> BlockId -> BlockId+lookupBid subst bid = case mapLookup bid subst of+                        Just bid  -> lookupBid subst bid+                        Nothing -> bid++-- Middle nodes and expressions can contain BlockIds, in particular in+-- CmmStackSlot and CmmBlock, so we have to use a special equality for+-- these.+--+eqMiddleWith :: (BlockId -> BlockId -> Bool)+             -> CmmNode O O -> CmmNode O O -> Bool+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)+  = r1 == r2 && eqExprWith eqBid e1 e2+eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)+  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2+eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)+                   (CmmUnsafeForeignCall t2 r2 a2)+  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2+eqMiddleWith _ _ _ = False++eqExprWith :: (BlockId -> BlockId -> Bool)+           -> CmmExpr -> CmmExpr -> Bool+eqExprWith eqBid = eq+ where+  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2+  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2+  CmmReg r1          `eq` CmmReg r2          = r1==r2+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2+  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2+  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2+  _e1                `eq` _e2                = False++  xs `eqs` ys = eqListWith eq xs ys++  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2+  eqLit l1 l2 = l1 == l2++  eqArea Old Old = True+  eqArea (Young id1) (Young id2) = eqBid id1 id2+  eqArea _ _ = False++-- Equality on the body of a block, modulo a function mapping block+-- IDs to block IDs.+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool+eqBlockBodyWith eqBid block block'+  {-+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False+  -}+  = equal+  where (_,m,l)   = blockSplit block+        nodes     = filter (not . dont_care) (blockToList m)+        (_,m',l') = blockSplit block'+        nodes'    = filter (not . dont_care) (blockToList m')++        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&+                eqLastWith eqBid l l'+++eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2+eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2+eqLastWith _ _ _ = False++eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool+eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'+eqMaybeWith _ Nothing Nothing = True+eqMaybeWith _ _ _ = False++eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs+eqListWith _ []       []       = True+eqListWith _ _        _        = False++-- | Given a block map, ensure that all "target" blocks are covered by+-- the same ticks as the respective "source" blocks. This not only+-- means copying ticks, but also adjusting tick scopes where+-- necessary.+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph+copyTicks env g+  | mapNull env = g+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap+  where -- Reverse block merge map+        blockMap = toBlockMap g+        revEnv = mapFoldlWithKey insertRev M.empty env+        insertRev m k x = M.insertWith (const (k:)) x [k] m+        -- Copy ticks and scopes into the given block+        copyTo block = case M.lookup (entryLabel block) revEnv of+          Nothing -> block+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls+        copy from to =+          let ticks = blockTicks from+              CmmEntry  _   scp0        = firstNode from+              (CmmEntry lbl scp1, code) = blockSplitHead to+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`+             foldr blockCons code (map CmmTick ticks)++-- Group by [Label]+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]+groupByLabel =+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))+    where+      go !m [] = TM.foldTM (:) m []+      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries+        where --k' = map (getKey . getUnique) k+              adjust Nothing       = Just (k,[v])+              adjust (Just (_,vs)) = Just (k,v:vs)++groupByInt :: (a -> Int) -> [a] -> [[a]]+groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs+   -- See Note [Unique Determinism and code generation]+  where+    go m x = alterUFM addEntry m (f x)+      where+        addEntry xs = Just $! maybe [x] (x:) xs
+ compiler/GHC/Cmm/ContFlowOpt.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module GHC.Cmm.ContFlowOpt+    ( cmmCfgOpts+    , cmmCfgOptsProc+    , removeUnreachableBlocksProc+    , replaceLabels+    )+where++import GhcPrelude hiding (succ, unzip, zip)++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList)+import Maybes+import Panic+import Util++import Control.Monad+++-- Note [What is shortcutting]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider this Cmm code:+--+-- L1: ...+--     goto L2;+-- L2: goto L3;+-- L3: ...+--+-- Here L2 is an empty block and contains only an unconditional branch+-- to L3. In this situation any block that jumps to L2 can jump+-- directly to L3:+--+-- L1: ...+--     goto L3;+-- L2: goto L3;+-- L3: ...+--+-- In this situation we say that we shortcut L2 to L3. One of+-- consequences of shortcutting is that some blocks of code may become+-- unreachable (in the example above this is true for L2).+++-- Note [Control-flow optimisations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- This optimisation does three things:+--+--   - If a block finishes in an unconditional branch to another block+--     and that is the only jump to that block we concatenate the+--     destination block at the end of the current one.+--+--   - If a block finishes in a call whose continuation block is a+--     goto, then we can shortcut the destination, making the+--     continuation block the destination of the goto - but see Note+--     [Shortcut call returns].+--+--   - For any block that is not a call we try to shortcut the+--     destination(s). Additionally, if a block ends with a+--     conditional branch we try to invert the condition.+--+-- Blocks are processed using postorder DFS traversal. A side effect+-- of determining traversal order with a graph search is elimination+-- of any blocks that are unreachable.+--+-- Transformations are improved by working from the end of the graph+-- towards the beginning, because we may be able to perform many+-- shortcuts in one go.+++-- Note [Shortcut call returns]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We are going to maintain the "current" graph (LabelMap CmmBlock) as+-- we go, and also a mapping from BlockId to BlockId, representing+-- continuation labels that we have renamed.  This latter mapping is+-- important because we might shortcut a CmmCall continuation.  For+-- example:+--+--    Sp[0] = L+--    call g returns to L+--    L: goto M+--    M: ...+--+-- So when we shortcut the L block, we need to replace not only+-- the continuation of the call, but also references to L in the+-- code (e.g. the assignment Sp[0] = L):+--+--    Sp[0] = M+--    call g returns to M+--    M: ...+--+-- So we keep track of which labels we have renamed and apply the mapping+-- at the end with replaceLabels.+++-- Note [Shortcut call returns and proc-points]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider this code that you might get from a recursive+-- let-no-escape:+--+--       goto L1+--      L1:+--       if (Hp > HpLim) then L2 else L3+--      L2:+--       call stg_gc_noregs returns to L4+--      L4:+--       goto L1+--      L3:+--       ...+--       goto L1+--+-- Then the control-flow optimiser shortcuts L4.  But that turns L1+-- into the call-return proc point, and every iteration of the loop+-- has to shuffle variables to and from the stack.  So we must *not*+-- shortcut L4.+--+-- Moreover not shortcutting call returns is probably fine.  If L4 can+-- concat with its branch target then it will still do so.  And we+-- save some compile time because we don't have to traverse all the+-- code in replaceLabels.+--+-- However, we probably do want to do this if we are splitting proc+-- points, because L1 will be a proc-point anyway, so merging it with+-- L4 reduces the number of proc points.  Unfortunately recursive+-- let-no-escapes won't generate very good code with proc-point+-- splitting on - we should probably compile them to explicitly use+-- the native calling convention instead.++cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph+cmmCfgOpts split g = fst (blockConcat split g)++cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl+cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'+    where (g', env) = blockConcat split g+          info' = info{ info_tbls = new_info_tbls }+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))++          -- If we changed any labels, then we have to update the info tables+          -- too, except for the top-level info table because that might be+          -- referred to by other procs.+          upd_info (k,info)+             | Just k' <- mapLookup k env+             = (k', if k' == g_entry g'+                       then info+                       else info{ cit_lbl = infoTblLbl k' })+             | otherwise+             = (k,info)+cmmCfgOptsProc _ top = top+++blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)+blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')+  where+     -- We might be able to shortcut the entry BlockId itself.+     -- Remember to update the shortcut_map, since we also have to+     -- update the info_tbls mapping now.+     (new_entry, shortcut_map')+       | Just entry_blk <- mapLookup entry_id new_blocks+       , Just dest      <- canShortcut entry_blk+       = (dest, mapInsert entry_id dest shortcut_map)+       | otherwise+       = (entry_id, shortcut_map)++     -- blocks are sorted in reverse postorder, but we want to go from the exit+     -- towards beginning, so we use foldr below.+     blocks = revPostorder g+     blockmap = foldl' (flip addBlock) emptyBody blocks++     -- Accumulator contains three components:+     --  * map of blocks in a graph+     --  * map of shortcut labels. See Note [Shortcut call returns]+     --  * map containing number of predecessors for each block. We discard+     --    it after we process all blocks.+     (new_blocks, shortcut_map, _) =+           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks++     -- Map of predecessors for initial graph. We increase number of+     -- predecessors for entry block by one to denote that it is+     -- target of a jump, even if no block in the current graph jumps+     -- to it.+     initialBackEdges = incPreds entry_id (predMap blocks)++     maybe_concat :: CmmBlock+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)+     maybe_concat block (!blocks, !shortcut_map, !backEdges)+        -- If:+        --   (1) current block ends with unconditional branch to b' and+        --   (2) it has exactly one predecessor (namely, current block)+        --+        -- Then:+        --   (1) append b' block at the end of current block+        --   (2) remove b' from the map of blocks+        --   (3) remove information about b' from predecessors map+        --+        -- Since we know that the block has only one predecessor we call+        -- mapDelete directly instead of calling decPreds.+        --+        -- Note that we always maintain an up-to-date list of predecessors, so+        -- we can ignore the contents of shortcut_map+        | CmmBranch b' <- last+        , hasOnePredecessor b'+        , Just blk' <- mapLookup b' blocks+        = let bid' = entryLabel blk'+          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks+             , shortcut_map+             , mapDelete b' backEdges )++        -- If:+        --   (1) we are splitting proc points (see Note+        --       [Shortcut call returns and proc-points]) and+        --   (2) current block is a CmmCall or CmmForeignCall with+        --       continuation b' and+        --   (3) we can shortcut that continuation to dest+        -- Then:+        --   (1) we change continuation to point to b'+        --   (2) create mapping from b' to dest+        --   (3) increase number of predecessors of dest by 1+        --   (4) decrease number of predecessors of b' by 1+        --+        -- Later we will use replaceLabels to substitute all occurrences of b'+        -- with dest.+        | splitting_procs+        , Just b'   <- callContinuation_maybe last+        , Just blk' <- mapLookup b' blocks+        , Just dest <- canShortcut blk'+        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks+          , mapInsert b' dest shortcut_map+          , decPreds b' $ incPreds dest backEdges )++        -- If:+        --   (1) a block does not end with a call+        -- Then:+        --   (1) if it ends with a conditional attempt to invert the+        --       conditional+        --   (2) attempt to shortcut all destination blocks+        --   (3) if new successors of a block are different from the old ones+        --       update the of predecessors accordingly+        --+        -- A special case of this is a situation when a block ends with an+        -- unconditional jump to a block that can be shortcut.+        | Nothing <- callContinuation_maybe last+        = let oldSuccs = successors last+              newSuccs = successors rewrite_last+          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks+             , shortcut_map+             , if oldSuccs == newSuccs+               then backEdges+               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )++        -- Otherwise don't do anything+        | otherwise+        = ( blocks, shortcut_map, backEdges )+        where+          (head, last) = blockSplitTail block+          bid = entryLabel block++          -- Changes continuation of a call to a specified label+          update_cont dest =+              case last of+                CmmCall{}        -> last { cml_cont = Just dest }+                CmmForeignCall{} -> last { succ = dest }+                _                -> panic "Can't shortcut continuation."++          -- Attempts to shortcut successors of last node+          shortcut_last = mapSuccessors shortcut last+            where+              shortcut l =+                 case mapLookup l blocks of+                   Just b | Just dest <- canShortcut b -> dest+                   _otherwise -> l++          rewrite_last+            -- Sometimes we can get rid of the conditional completely.+            | CmmCondBranch _cond t f _l <- shortcut_last+            , t == f+            = CmmBranch t++            -- See Note [Invert Cmm conditionals]+            | CmmCondBranch cond t f l <- shortcut_last+            , hasOnePredecessor t -- inverting will make t a fallthrough+            , likelyTrue l || (numPreds f > 1)+            , Just cond' <- maybeInvertCmmExpr cond+            = CmmCondBranch cond' f t (invertLikeliness l)++            -- If all jump destinations of a switch go to the+            -- same target eliminate the switch.+            | CmmSwitch _expr targets <- shortcut_last+            , (t:ts) <- switchTargetsToList targets+            , all (== t) ts+            = CmmBranch t++            | otherwise+            = shortcut_last++          likelyTrue (Just True)   = True+          likelyTrue _             = False++          invertLikeliness :: Maybe Bool -> Maybe Bool+          invertLikeliness         = fmap not++          -- Number of predecessors for a block+          numPreds bid = mapLookup bid backEdges `orElse` 0++          hasOnePredecessor b = numPreds b == 1++{-+  Note [Invert Cmm conditionals]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  The native code generator always produces jumps to the true branch.+  Falling through to the false branch is however faster. So we try to+  arrange for that to happen.+  This means we invert the condition if:+  * The likely path will become a fallthrough.+  * We can't guarantee a fallthrough for the false branch but for the+    true branch.++  In some cases it's faster to avoid inverting when the false branch is likely.+  However determining when that is the case is neither easy nor cheap so for+  now we always invert as this produces smaller binaries and code that is+  equally fast on average. (On an i7-6700K)++  TODO:+  There is also the edge case when both branches have multiple predecessors.+  In this case we could assume that we will end up with a jump for BOTH+  branches. In this case it might be best to put the likely path in the true+  branch especially if there are large numbers of predecessors as this saves+  us the jump thats not taken. However I haven't tested this and as of early+  2018 we almost never generate cmm where this would apply.+-}++-- Functions for incrementing and decrementing number of predecessors. If+-- decrementing would set the predecessor count to 0, we remove entry from the+-- map.+-- Invariant: if a block has no predecessors it should be dropped from the+-- graph because it is unreachable. maybe_concat is constructed to maintain+-- that invariant, but calling replaceLabels may introduce unreachable blocks.+-- We rely on subsequent passes in the Cmm pipeline to remove unreachable+-- blocks.+incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int+incPreds bid edges = mapInsertWith (+) bid 1 edges+decPreds bid edges = case mapLookup bid edges of+                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges+                       Just _                 -> mapDelete bid edges+                       _                      -> edges+++-- Checks if a block consists only of "goto dest". If it does than we return+-- "Just dest" label. See Note [What is shortcutting]+canShortcut :: CmmBlock -> Maybe BlockId+canShortcut block+    | (_, middle, CmmBranch dest) <- blockSplit block+    , all dont_care $ blockToList middle+    = Just dest+    | otherwise+    = Nothing+    where dont_care CmmComment{} = True+          dont_care CmmTick{}    = True+          dont_care _other       = False++-- Concatenates two blocks. First one is assumed to be open on exit, the second+-- is assumed to be closed on entry (i.e. it has a label attached to it, which+-- the splice function removes by calling snd on result of blockSplitHead).+splice :: Block CmmNode C O -> CmmBlock -> CmmBlock+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1+  where (CmmEntry lbl sc0, code0) = blockSplitHead head+        (CmmEntry _   sc1, code1) = blockSplitHead rest+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)++-- If node is a call with continuation call return Just label of that+-- continuation. Otherwise return Nothing.+callContinuation_maybe :: CmmNode O C -> Maybe BlockId+callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b+callContinuation_maybe (CmmForeignCall { succ = b })   = Just b+callContinuation_maybe _ = Nothing+++-- Map over the CmmGraph, replacing each label with its mapping in the+-- supplied LabelMap.+replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph+replaceLabels env g+  | mapNull env = g+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g+   where+     replace_eid g = g {g_entry = lookup (g_entry g)}+     lookup id = mapLookup id env `orElse` id++     txnode :: CmmNode e x -> CmmNode e x+     txnode (CmmBranch bid) = CmmBranch (lookup bid)+     txnode (CmmCondBranch p t f l) =+       mkCmmCondBranch (exp p) (lookup t) (lookup f) l+     txnode (CmmSwitch e ids) =+       CmmSwitch (exp e) (mapSwitchTargets lookup ids)+     txnode (CmmCall t k rg a res r) =+       CmmCall (exp t) (liftM lookup k) rg a res r+     txnode fc@CmmForeignCall{} =+       fc{ args = map exp (args fc), succ = lookup (succ fc) }+     txnode other = mapExpDeep exp other++     exp :: CmmExpr -> CmmExpr+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))+     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i+     exp e                                      = e++mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C+mkCmmCondBranch p t f l =+  if t == f then CmmBranch t else CmmCondBranch p t f l++-- Build a map from a block to its set of predecessors.+predMap :: [CmmBlock] -> LabelMap Int+predMap blocks = foldr add_preds mapEmpty blocks+  where+    add_preds block env = foldr add env (successors block)+      where add lbl env = mapInsertWith (+) lbl 1 env++-- Removing unreachable blocks+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl+removeUnreachableBlocksProc proc@(CmmProc info lbl live g)+   | used_blocks `lengthLessThan` mapSize (toBlockMap g)+   = CmmProc info' lbl live g'+   | otherwise+   = proc+   where+     g'    = ofBlockList (g_entry g) used_blocks+     info' = info { info_tbls = keep_used (info_tbls info) }+             -- Remove any info_tbls for unreachable++     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable+     keep_used bs = mapFoldlWithKey keep mapEmpty bs++     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable+     keep env l i | l `setMember` used_lbls = mapInsert l i env+                  | otherwise               = env++     used_blocks :: [CmmBlock]+     used_blocks = revPostorder g++     used_lbls :: LabelSet+     used_lbls = setFromList $ map entryLabel used_blocks
+ compiler/GHC/Cmm/Dataflow.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++--+-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,+-- and Norman Ramsey+--+-- Modifications copyright (c) The University of Glasgow 2012+--+-- This module is a specialised and optimised version of+-- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is+-- specialised to the UniqSM monad.+--++module GHC.Cmm.Dataflow+  ( C, O, Block+  , lastNode, entryLabel+  , foldNodesBwdOO+  , foldRewriteNodesBwdOO+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)+  , TransferFun, RewriteFun+  , Fact, FactBase+  , getFact, mkFactBase+  , analyzeCmmFwd, analyzeCmmBwd+  , rewriteCmmBwd+  , changedIf+  , joinOutFacts+  , joinFacts+  )+where++import GhcPrelude++import GHC.Cmm+import UniqSupply++import Data.Array+import Data.Maybe+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label++type family   Fact (x :: Extensibility) f :: *+type instance Fact C f = FactBase f+type instance Fact O f = f++newtype OldFact a = OldFact a++newtype NewFact a = NewFact a++-- | The result of joining OldFact and NewFact.+data JoinedFact a+    = Changed !a     -- ^ Result is different than OldFact.+    | NotChanged !a  -- ^ Result is the same as OldFact.++getJoined :: JoinedFact a -> a+getJoined (Changed a) = a+getJoined (NotChanged a) = a++changedIf :: Bool -> a -> JoinedFact a+changedIf True = Changed+changedIf False = NotChanged++type JoinFun a = OldFact a -> NewFact a -> JoinedFact a++data DataflowLattice a = DataflowLattice+    { fact_bot :: a+    , fact_join :: JoinFun a+    }++data Direction = Fwd | Bwd++type TransferFun f = CmmBlock -> FactBase f -> FactBase f++-- | Function for rewrtiting and analysis combined. To be used with+-- @rewriteCmm@.+--+-- Currently set to work with @UniqSM@ monad, but we could probably abstract+-- that away (if we do that, we might want to specialize the fixpoint algorithms+-- to the particular monads through SPECIALIZE).+type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)++analyzeCmmBwd, analyzeCmmFwd+    :: DataflowLattice f+    -> TransferFun f+    -> CmmGraph+    -> FactBase f+    -> FactBase f+analyzeCmmBwd = analyzeCmm Bwd+analyzeCmmFwd = analyzeCmm Fwd++analyzeCmm+    :: Direction+    -> DataflowLattice f+    -> TransferFun f+    -> CmmGraph+    -> FactBase f+    -> FactBase f+analyzeCmm dir lattice transfer cmmGraph initFact =+    {-# SCC analyzeCmm #-}+    let entry = g_entry cmmGraph+        hooplGraph = g_graph cmmGraph+        blockMap =+            case hooplGraph of+                GMany NothingO bm NothingO -> bm+    in fixpointAnalysis dir lattice transfer entry blockMap initFact++-- Fixpoint algorithm.+fixpointAnalysis+    :: forall f.+       Direction+    -> DataflowLattice f+    -> TransferFun f+    -> Label+    -> LabelMap CmmBlock+    -> FactBase f+    -> FactBase f+fixpointAnalysis direction lattice do_block entry blockmap = loop start+  where+    -- Sorting the blocks helps to minimize the number of times we need to+    -- process blocks. For instance, for forward analysis we want to look at+    -- blocks in reverse postorder. Also, see comments for sortBlocks.+    blocks     = sortBlocks direction entry blockmap+    num_blocks = length blocks+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList+      [0 .. num_blocks - 1]+    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks+    join       = fact_join lattice++    loop+        :: IntHeap     -- ^ Worklist, i.e., blocks to process+        -> FactBase f  -- ^ Current result (increases monotonically)+        -> FactBase f+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =+        let block = block_arr ! index+            out_facts = {-# SCC "do_block" #-} do_block block fbase1+            -- For each of the outgoing edges, we join it with the current+            -- information in fbase1 and (if something changed) we update it+            -- and add the affected blocks to the worklist.+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}+                mapFoldlWithKey+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts+        in loop todo2 fbase2+    loop _ !fbase1 = fbase1++rewriteCmmBwd+    :: DataflowLattice f+    -> RewriteFun f+    -> CmmGraph+    -> FactBase f+    -> UniqSM (CmmGraph, FactBase f)+rewriteCmmBwd = rewriteCmm Bwd++rewriteCmm+    :: Direction+    -> DataflowLattice f+    -> RewriteFun f+    -> CmmGraph+    -> FactBase f+    -> UniqSM (CmmGraph, FactBase f)+rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do+    let entry = g_entry cmmGraph+        hooplGraph = g_graph cmmGraph+        blockMap1 =+            case hooplGraph of+                GMany NothingO bm NothingO -> bm+    (blockMap2, facts) <-+        fixpointRewrite dir lattice rwFun entry blockMap1 initFact+    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)++fixpointRewrite+    :: forall f.+       Direction+    -> DataflowLattice f+    -> RewriteFun f+    -> Label+    -> LabelMap CmmBlock+    -> FactBase f+    -> UniqSM (LabelMap CmmBlock, FactBase f)+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap+  where+    -- Sorting the blocks helps to minimize the number of times we need to+    -- process blocks. For instance, for forward analysis we want to look at+    -- blocks in reverse postorder. Also, see comments for sortBlocks.+    blocks     = sortBlocks dir entry blockmap+    num_blocks = length blocks+    block_arr  = {-# SCC "block_arr_rewrite" #-}+                 listArray (0, num_blocks - 1) blocks+    start      = {-# SCC "start_rewrite" #-}+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]+    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks+    join       = fact_join lattice++    loop+        :: IntHeap            -- ^ Worklist, i.e., blocks to process+        -> LabelMap CmmBlock  -- ^ Rewritten blocks.+        -> FactBase f         -- ^ Current facts.+        -> UniqSM (LabelMap CmmBlock, FactBase f)+    loop todo !blocks1 !fbase1+      | Just (index, todo1) <- IntSet.minView todo = do+        -- Note that we use the *original* block here. This is important.+        -- We're optimistically rewriting blocks even before reaching the fixed+        -- point, which means that the rewrite might be incorrect. So if the+        -- facts change, we need to rewrite the original block again (taking+        -- into account the new facts).+        let block = block_arr ! index+        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}+            do_block block fbase1+        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1+            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}+                mapFoldlWithKey+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts+        loop todo2 blocks2 fbase2+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)+++{-+Note [Unreachable blocks]+~~~~~~~~~~~~~~~~~~~~~~~~~+A block that is not in the domain of tfb_fbase is "currently unreachable".+A currently-unreachable block is not even analyzed.  Reason: consider+constant prop and this graph, with entry point L1:+  L1: x:=3; goto L4+  L2: x:=4; goto L4+  L4: if x>3 goto L2 else goto L5+Here L2 is actually unreachable, but if we process it with bottom input fact,+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.++* If a currently-unreachable block is not analyzed, then its rewritten+  graph will not be accumulated in tfb_rg.  And that is good:+  unreachable blocks simply do not appear in the output.++* Note that clients must be careful to provide a fact (even if bottom)+  for each entry point. Otherwise useful blocks may be garbage collected.++* Note that updateFact must set the change-flag if a label goes from+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the+  real fact lattice is+       UNR+       bottom+       the points above bottom++* Even if the fact is going from UNR to bottom, we still call the+  client's fact_join function because it might give the client+  some useful debugging information.++* All of this only applies for *forward* ixpoints.  For the backward+  case we must treat every block as reachable; it might finish with a+  'return', and therefore have no successors, for example.+-}+++-----------------------------------------------------------------------------+--  Pieces that are shared by fixpoint and fixpoint_anal+-----------------------------------------------------------------------------++-- | Sort the blocks into the right order for analysis. This means reverse+-- postorder for a forward analysis. For the backward one, we simply reverse+-- that (see Note [Backward vs forward analysis]).+sortBlocks+    :: NonLocal n+    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]+sortBlocks direction entry blockmap =+    case direction of+        Fwd -> fwd+        Bwd -> reverse fwd+  where+    fwd = revPostorderFrom blockmap entry++-- Note [Backward vs forward analysis]+--+-- The forward and backward cases are not dual.  In the forward case, the entry+-- points are known, and one simply traverses the body blocks from those points.+-- In the backward case, something is known about the exit points, but a+-- backward analysis must also include reachable blocks that don't reach the+-- exit, as in a procedure that loops forever and has side effects.)+-- For instance, let E be the entry and X the exit blocks (arrows indicate+-- control flow)+--   E -> X+--   E -> B+--   B -> C+--   C -> B+-- We do need to include B and C even though they're unreachable in the+-- *reverse* graph (that we could use for backward analysis):+--   E <- X+--   E <- B+--   B <- C+--   C <- B+-- So when sorting the blocks for the backward analysis, we simply take the+-- reverse of what is used for the forward one.+++-- | Construct a mapping from a @Label@ to the block indexes that should be+-- re-analyzed if the facts at that @Label@ change.+--+-- Note that we're considering here the entry point of the block, so if the+-- facts change at the entry:+-- * for a backward analysis we need to re-analyze all the predecessors, but+-- * for a forward analysis, we only need to re-analyze the current block+--   (and that will in turn propagate facts into its successors).+mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet+mkDepBlocks Fwd blocks = go blocks 0 mapEmpty+  where+    go []     !_ !dep_map = dep_map+    go (b:bs) !n !dep_map =+        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map+mkDepBlocks Bwd blocks = go blocks 0 mapEmpty+  where+    go []     !_ !dep_map = dep_map+    go (b:bs) !n !dep_map =+        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m+        in go bs (n + 1) $ foldl' insert dep_map (successors b)++-- | After some new facts have been generated by analysing a block, we+-- fold this function over them to generate (a) a list of block+-- indices to (re-)analyse, and (b) the new FactBase.+updateFact+    :: JoinFun f+    -> LabelMap IntSet+    -> (IntHeap, FactBase f)+    -> Label+    -> f -- out fact+    -> (IntHeap, FactBase f)+updateFact fact_join dep_blocks (todo, fbase) lbl new_fact+  = case lookupFact lbl fbase of+      Nothing ->+          -- Note [No old fact]+          let !z = mapInsert lbl new_fact fbase in (changed, z)+      Just old_fact ->+          case fact_join (OldFact old_fact) (NewFact new_fact) of+              (NotChanged _) -> (todo, fbase)+              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)+  where+    changed = todo `IntSet.union`+              mapFindWithDefault IntSet.empty lbl dep_blocks++{-+Note [No old fact]++We know that the new_fact is >= _|_, so we don't need to join.  However,+if the new fact is also _|_, and we have already analysed its block,+we don't need to record a change.  So there's a tradeoff here.  It turns+out that always recording a change is faster.+-}++----------------------------------------------------------------+--       Utilities+----------------------------------------------------------------++-- Fact lookup: the fact `orelse` bottom+getFact  :: DataflowLattice f -> Label -> FactBase f -> f+getFact lat l fb = case lookupFact l fb of Just  f -> f+                                           Nothing -> fact_bot lat++-- | Returns the result of joining the facts from all the successors of the+-- provided node or block.+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f+joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts+  where+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)+    facts =+        [ fromJust fact+        | s <- successors nonLocal+        , let fact = lookupFact s fact_base+        , isJust fact+        ]++joinFacts :: DataflowLattice f -> [f] -> f+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts+  where+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)++-- | Returns the joined facts for each label.+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f+mkFactBase lattice = foldl' add mapEmpty+  where+    join = fact_join lattice++    add result (l, f1) =+        let !newFact =+                case mapLookup l result of+                    Nothing -> f1+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)+        in mapInsert l newFact result++-- | Folds backward over all nodes of an open-open block.+-- Strict in the accumulator.+foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f+foldNodesBwdOO funOO = go+  where+    go (BCat b1 b2) f = go b1 $! go b2 f+    go (BSnoc h n) f = go h $! funOO n f+    go (BCons n t) f = funOO n $! go t f+    go (BMiddle n) f = funOO n f+    go BNil f = f+{-# INLINABLE foldNodesBwdOO #-}++-- | Folds backward over all the nodes of an open-open block and allows+-- rewriting them. The accumulator is both the block of nodes and @f@ (usually+-- dataflow facts).+-- Strict in both accumulated parts.+foldRewriteNodesBwdOO+    :: forall f.+       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))+    -> Block CmmNode O O+    -> f+    -> UniqSM (Block CmmNode O O, f)+foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts+  where+    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1+    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1+    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1+    go (BMiddle node) !fact1 = rewriteOO node fact1+    go BNil !fact = return (BNil, fact)++    comp rew1 rew2 = \f1 -> do+        (b, f2) <- rew2 f1+        (a, !f3) <- rew1 f2+        let !c = joinBlocksOO a b+        return (c, f3)+    {-# INLINE comp #-}+{-# INLINABLE foldRewriteNodesBwdOO #-}++joinBlocksOO :: Block n O O -> Block n O O -> Block n O O+joinBlocksOO BNil b = b+joinBlocksOO b BNil = b+joinBlocksOO (BMiddle n) b = blockCons n b+joinBlocksOO b (BMiddle n) = blockSnoc b n+joinBlocksOO b1 b2 = BCat b1 b2++type IntHeap = IntSet
+ compiler/GHC/Cmm/DebugBlock.hs view
@@ -0,0 +1,548 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- Debugging data+--+-- Association of debug data on the Cmm level, with methods to encode it in+-- event log format for later inclusion in profiling event logs.+--+-----------------------------------------------------------------------------++module GHC.Cmm.DebugBlock (++  DebugBlock(..),+  cmmDebugGen,+  cmmDebugLabels,+  cmmDebugLink,+  debugToMap,++  -- * Unwinding information+  UnwindTable, UnwindPoint(..),+  UnwindExpr(..), toUnwindExpr+  ) where++import GhcPrelude++import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Cmm.Utils+import CoreSyn+import FastString      ( nilFS, mkFastString )+import Module+import Outputable+import GHC.Cmm.Ppr.Expr ( pprExpr )+import SrcLoc+import Util            ( seqList )++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label++import Data.Maybe+import Data.List     ( minimumBy, nubBy )+import Data.Ord      ( comparing )+import qualified Data.Map as Map+import Data.Either   ( partitionEithers )++-- | Debug information about a block of code. Ticks scope over nested+-- blocks.+data DebugBlock =+  DebugBlock+  { dblProcedure  :: !Label        -- ^ Entry label of containing proc+  , dblLabel      :: !Label        -- ^ Hoopl label+  , dblCLabel     :: !CLabel       -- ^ Output label+  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?+  , dblParent     :: !(Maybe DebugBlock)+    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]+  , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block+  , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block+  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to+                                   -- other blocks. @Nothing@ means+                                   -- the block was optimized out+  , dblUnwind     :: [UnwindPoint]+  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks+  }++instance Outputable DebugBlock where+  ppr blk = (if | dblProcedure blk == dblLabel blk+                -> text "proc"+                | dblHasInfoTbl blk+                -> text "pp-blk"+                | otherwise+                -> text "blk") <+>+            ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>+            (maybe empty ppr (dblSourceTick blk)) <+>+            (maybe (text "removed") ((text "pos " <>) . ppr)+                   (dblPosition blk)) <+>+            (ppr (dblUnwind blk)) $+$+            (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))++-- | Intermediate data structure holding debug-relevant context information+-- about a block.+type BlockContext = (CmmBlock, RawCmmDecl)++-- | Extract debug data from a group of procedures. We will prefer+-- source notes that come from the given module (presumably the module+-- that we are currently compiling).+cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]+cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes+  where+      blockCtxs :: Map.Map CmmTickScope [BlockContext]+      blockCtxs = blockContexts decls++      -- Analyse tick scope structure: Each one is either a top-level+      -- tick scope, or the child of another.+      (topScopes, childScopes)+        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs+      findP tsc GlobalScope = Left tsc -- top scope+      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)+                    | otherwise                   = findP tsc scp'+        where -- Note that we only following the left parent of+              -- combined scopes. This loses us ticks, which we will+              -- recover by copying ticks below.+              scp' | SubScope _ scp' <- scp      = scp'+                   | CombinedScope scp' _ <- scp = scp'+                   | otherwise                   = panic "findP impossible"++      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes++      -- This allows us to recover ticks that we lost by flattening+      -- the graph. Basically, if the parent is A but the child is+      -- CBA, we know that there is no BA, because it would have taken+      -- priority - but there might be a B scope, with ticks that+      -- would not be associated with our child anymore. Note however+      -- that there might be other childs (DB), which we have to+      -- filter out.+      --+      -- We expect this to be called rarely, which is why we are not+      -- trying too hard to be efficient here. In many cases we won't+      -- have to construct blockCtxsU in the first place.+      ticksToCopy :: CmmTickScope -> [CmmTickish]+      ticksToCopy (CombinedScope scp s) = go s+        where go s | scp `isTickSubScope` s   = [] -- done+                   | SubScope _ s' <- s       = ticks ++ go s'+                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2+                   | otherwise                = panic "ticksToCopy impossible"+                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs+      ticksToCopy _ = []+      bCtxsTicks = concatMap (blockTicks . fst)++      -- Finding the "best" source tick is somewhat arbitrary -- we+      -- select the first source span, while preferring source ticks+      -- from the same source file.  Furthermore, dumps take priority+      -- (if we generated one, we probably want debug information to+      -- refer to it).+      bestSrcTick = minimumBy (comparing rangeRating)+      rangeRating (SourceNote span _)+        | srcSpanFile span == thisFile = 1+        | otherwise                    = 2 :: Int+      rangeRating note                 = pprPanic "rangeRating" (ppr note)+      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc++      -- Returns block tree for this scope as well as all nested+      -- scopes. Note that if there are multiple blocks in the (exact)+      -- same scope we elect one as the "branch" node and add the rest+      -- as children.+      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock+      blocksForScope cstick scope = mkBlock True (head bctxs)+        where bctxs = fromJust $ Map.lookup scope blockCtxs+              nested = fromMaybe [] $ Map.lookup scope scopeMap+              childs = map (mkBlock False) (tail bctxs) +++                       map (blocksForScope stick) nested++              mkBlock :: Bool -> BlockContext -> DebugBlock+              mkBlock top (block, prc)+                = DebugBlock { dblProcedure    = g_entry graph+                             , dblLabel        = label+                             , dblCLabel       = case info of+                                 Just (Statics infoLbl _)   -> infoLbl+                                 Nothing+                                   | g_entry graph == label -> entryLbl+                                   | otherwise              -> blockLbl label+                             , dblHasInfoTbl   = isJust info+                             , dblParent       = Nothing+                             , dblTicks        = ticks+                             , dblPosition     = Nothing -- see cmmDebugLink+                             , dblSourceTick   = stick+                             , dblBlocks       = blocks+                             , dblUnwind       = []+                             }+                where (CmmProc infos entryLbl _ graph) = prc+                      label = entryLabel block+                      info = mapLookup label infos+                      blocks | top       = seqList childs childs+                             | otherwise = []++              -- A source tick scopes over all nested blocks. However+              -- their source ticks might take priority.+              isSourceTick SourceNote {} = True+              isSourceTick _             = False+              -- Collect ticks from all blocks inside the tick scope.+              -- We attempt to filter out duplicates while we're at it.+              ticks = nubBy (flip tickishContains) $+                      bCtxsTicks bctxs ++ ticksToCopy scope+              stick = case filter isSourceTick ticks of+                []     -> cstick+                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)++-- | Build a map of blocks sorted by their tick scopes+--+-- This involves a pre-order traversal, as we want blocks in rough+-- control flow order (so ticks have a chance to be sorted in the+-- right order).+blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]+blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls+  where walkProc :: RawCmmDecl+                 -> Map.Map CmmTickScope [BlockContext]+                 -> Map.Map CmmTickScope [BlockContext]+        walkProc CmmData{}                 m = m+        walkProc prc@(CmmProc _ _ _ graph) m+          | mapNull blocks = m+          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)+          where blocks = toBlockMap graph+                entry  = [mapFind (g_entry graph) blocks]+                emptyLbls = setEmpty :: LabelSet++        walkBlock :: RawCmmDecl -> [Block CmmNode C C]+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+        walkBlock _   []             c            = c+        walkBlock prc (block:blocks) (visited, m)+          | lbl `setMember` visited+          = walkBlock prc blocks (visited, m)+          | otherwise+          = walkBlock prc blocks $+            walkBlock prc succs+              (lbl `setInsert` visited,+               insertMulti scope (block, prc) m)+          where CmmEntry lbl scope = firstNode block+                (CmmProc _ _ _ graph) = prc+                succs = map (flip mapFind (toBlockMap graph))+                            (successors (lastNode block))+        mapFind = mapFindWithDefault (error "contextTree: block not found!")++insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]+insertMulti k v = Map.insertWith (const (v:)) k [v]++cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]+cmmDebugLabels isMeta nats = seqList lbls lbls+  where -- Find order in which procedures will be generated by the+        -- back-end (that actually matters for DWARF generation).+        --+        -- Note that we might encounter blocks that are missing or only+        -- consist of meta instructions -- we will declare them missing,+        -- which will skip debug data generation without messing up the+        -- block hierarchy.+        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats+        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs+        getBlocks _other                         = []+        allMeta (BasicBlock _ instrs) = all isMeta instrs++-- | Sets position and unwind table fields in the debug block tree according to+-- native generated code.+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]+             -> [DebugBlock] -> [DebugBlock]+cmmDebugLink labels unwindPts blocks = map link blocks+  where blockPos :: LabelMap Int+        blockPos = mapFromList $ flip zip [0..] labels+        link block = block { dblPosition = mapLookup (dblLabel block) blockPos+                           , dblBlocks   = map link (dblBlocks block)+                           , dblUnwind   = fromMaybe mempty+                                         $ mapLookup (dblLabel block) unwindPts+                           }++-- | Converts debug blocks into a label map for easier lookups+debugToMap :: [DebugBlock] -> LabelMap DebugBlock+debugToMap = mapUnions . map go+   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)++{-+Note [What is this unwinding business?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unwinding tables are a variety of debugging information used by debugging tools+to reconstruct the execution history of a program at runtime. These tables+consist of sets of "instructions", one set for every instruction in the program,+which describe how to reconstruct the state of the machine at the point where+the current procedure was called. For instance, consider the following annotated+pseudo-code,++  a_fun:+    add rsp, 8            -- unwind: rsp = rsp - 8+    mov rax, 1            -- unwind: rax = unknown+    call another_block+    sub rsp, 8            -- unwind: rsp = rsp++We see that attached to each instruction there is an "unwind" annotation, which+provides a relationship between each updated register and its value at the+time of entry to a_fun. This is the sort of information that allows gdb to give+you a stack backtrace given the execution state of your program. This+unwinding information is captured in various ways by various debug information+formats; in the case of DWARF (the only format supported by GHC) it is known as+Call Frame Information (CFI) and can be found in the .debug.frames section of+your object files.++Currently we only bother to produce unwinding information for registers which+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp+(which is the STG stack pointer) and $rsp (the C stack pointer).++Let's consider how GHC would annotate a C-- program with unwinding information+with a typical C-- procedure as would come from the STG-to-Cmm code generator,++  entry()+     { c2fe:+           v :: P64 = R2;+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;+       c2ff:+           R2 = v :: P64;+           R1 = test_closure;+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;+       c2fg:+           I64[Sp - 8] = c2dD;+           R1 = v :: P64;+           Sp = Sp - 8;          // Sp updated here+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;+       c2dE:+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;+       c2dD:+           w :: P64 = R1;+           Hp = Hp + 48;+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;+       ...+  },++Let's consider how this procedure will be decorated with unwind information+(largely by GHC.Cmm.LayoutStack). Naturally, when we enter the procedure `entry` the+value of Sp is no different from what it was at its call site. Therefore we will+add an `unwind` statement saying this at the beginning of its unwind-annotated+code,++  entry()+     { c2fe:+           unwind Sp = Just Sp + 0;+           v :: P64 = R2;+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;++After c2fe we may pass to either c2ff or c2fg; let's first consider the+former. In this case there is nothing in particular that we need to do other+than reiterate what we already know about Sp,++       c2ff:+           unwind Sp = Just Sp + 0;+           R2 = v :: P64;+           R1 = test_closure;+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;++In contrast, c2fg updates Sp midway through its body. To ensure that unwinding+can happen correctly after this point we must include an unwind statement there,+in addition to the usual beginning-of-block statement,++       c2fg:+           unwind Sp = Just Sp + 0;+           I64[Sp - 8] = c2dD;+           R1 = v :: P64;+           Sp = Sp - 8;+           unwind Sp = Just Sp + 8;+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;++The remaining blocks are simple,++       c2dE:+           unwind Sp = Just Sp + 8;+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;+       c2dD:+           unwind Sp = Just Sp + 8;+           w :: P64 = R1;+           Hp = Hp + 48;+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;+       ...+  },+++The flow of unwinding information through the compiler is a bit convoluted:++ * C-- begins life in StgToCmm without any unwind information. This is because we+   haven't actually done any register assignment or stack layout yet, so there+   is no need for unwind information.++ * GHC.Cmm.LayoutStack figures out how to layout each procedure's stack, and produces+   appropriate unwinding nodes for each adjustment of the STG Sp register.++ * The unwind nodes are carried through the sinking pass. Currently this is+   guaranteed not to invalidate unwind information since it won't touch stores+   to Sp, but this will need revisiting if CmmSink gets smarter in the future.++ * Eventually we make it to the native code generator backend which can then+   preserve the unwind nodes in its machine-specific instructions. In so doing+   the backend can also modify or add unwinding information; this is necessary,+   for instance, in the case of x86-64, where adjustment of $rsp may be+   necessary during calls to native foreign code due to the native calling+   convention.++ * The NCG then retrieves the final unwinding table for each block from the+   backend with extractUnwindPoints.++ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen++ * These DebugBlocks are then converted to, e.g., DWARF unwinding tables+   (by the Dwarf module) and emitted in the final object.++See also:+  Note [Unwinding information in the NCG] in AsmCodeGen,+  Note [Unwind pseudo-instruction in Cmm],+  Note [Debugging DWARF unwinding info].+++Note [Debugging DWARF unwinding info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For debugging generated unwinding info I've found it most useful to dump the+disassembled binary with objdump -D and dump the debug info with+readelf --debug-dump=frames-interp.++You should get something like this:++  0000000000000010 <stg_catch_frame_info>:+    10:   48 83 c5 18             add    $0x18,%rbp+    14:   ff 65 00                jmpq   *0x0(%rbp)++and:++  Contents of the .debug_frame section:++  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16+     LOC           CFA      rbp   rsp   ra+  0000000000000000 rbp+0    v+0   s     c+0++  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017+     LOC           CFA      rbp   rsp   ra+  000000000000000f rbp+0    v+0   s     c+0+  000000000000000f rbp+24   v+0   s     c+0++To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in+Appendix 5 (page 101 of the pdf) and more details in the relevant section.++The key thing to keep in mind is that the value at LOC is the value from+*before* the instruction at LOC executes. In other words it answers the+question: if my $rip is at LOC, how do I get the relevant values given the+values obtained through unwinding so far.++If the readelf --debug-dump=frames-interp output looks wrong, it may also be+useful to look at readelf --debug-dump=frames, which is closer to the+information that GHC generated.++It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm+-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]+explains how to interpret it.++Inside gdb there are a couple useful commands for inspecting frames.+For example:++  gdb> info frame <num>++It shows the values of registers obtained through unwinding.++Another useful thing to try when debugging the DWARF unwinding is to enable+extra debugging output in GDB:++  gdb> set debug frame 1++This makes GDB produce a trace of its internal workings. Having gone this far,+it's just a tiny step to run GDB in GDB. Make sure you install debugging+symbols for gdb if you obtain it through a package manager.++Keep in mind that the current release of GDB has an instruction pointer handling+heuristic that works well for C-like languages, but doesn't always work for+Haskell. See Note [Info Offset] in Dwarf.Types for more details.++Note [Unwind pseudo-instruction in Cmm]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't+generate any assembly, but controls what DWARF unwinding information gets+generated.++It's important to understand what ranges of code the unwind pseudo-instruction+refers to.+For a sequence of CmmNodes like:++  A // starts at addr X and ends at addr Y-1+  unwind Sp = Just Sp + 16;+  B // starts at addr Y and ends at addr Z++the unwind statement reflects the state after A has executed, but before B+has executed. If you consult the Note [Debugging DWARF unwinding info], the+LOC this information will end up in is Y.+-}++-- | A label associated with an 'UnwindTable'+data UnwindPoint = UnwindPoint !CLabel !UnwindTable++instance Outputable UnwindPoint where+  ppr (UnwindPoint lbl uws) =+      braces $ ppr lbl<>colon+      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)+    where+      pprUw (g, expr) = ppr g <> char '=' <> ppr expr++-- | Maps registers to expressions that yield their "old" values+-- further up the stack. Most interesting for the stack pointer @Sp@,+-- but might be useful to document saved registers, too. Note that a+-- register's value will be 'Nothing' when the register's previous+-- value cannot be reconstructed.+type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)++-- | Expressions, used for unwind information+data UnwindExpr = UwConst !Int                  -- ^ literal value+                | UwReg !GlobalReg !Int         -- ^ register plus offset+                | UwDeref UnwindExpr            -- ^ pointer dereferencing+                | UwLabel CLabel+                | UwPlus UnwindExpr UnwindExpr+                | UwMinus UnwindExpr UnwindExpr+                | UwTimes UnwindExpr UnwindExpr+                deriving (Eq)++instance Outputable UnwindExpr where+  pprPrec _ (UwConst i)     = ppr i+  pprPrec _ (UwReg g 0)     = ppr g+  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))+  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e+  pprPrec _ (UwLabel l)     = pprPrec 3 l+  pprPrec p (UwPlus e0 e1)  | p <= 0+                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1+  pprPrec p (UwMinus e0 e1) | p <= 0+                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1+  pprPrec p (UwTimes e0 e1) | p <= 1+                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1+  pprPrec _ other           = parens (pprPrec 0 other)++-- | Conversion of Cmm expressions to unwind expressions. We check for+-- unsupported operator usages and simplify the expression as far as+-- possible.+toUnwindExpr :: CmmExpr -> UnwindExpr+toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)+toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l+toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i+toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0+toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)+toUnwindExpr e@(CmmMachOp op [e1, e2])   =+  case (op, toUnwindExpr e1, toUnwindExpr e2) of+    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)+    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)+    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)+    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)+    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)+    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)+    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2+    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2+    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2+    _otherwise -> pprPanic "Unsupported operator in unwind expression!"+                           (pprExpr e)+toUnwindExpr e+  = pprPanic "Unsupported unwind expression!" (ppr e)
+ compiler/GHC/Cmm/Graph.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE BangPatterns, GADTs #-}++module GHC.Cmm.Graph+  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)+  , (<*>), catAGraphs+  , mkLabel, mkMiddle, mkLast, outOfLine+  , lgraphOfAGraph, labelAGraph++  , stackStubExpr+  , mkNop, mkAssign, mkStore+  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo+  , mkJumpReturnsTo+  , mkJump, mkJumpExtra+  , mkRawJump+  , mkCbranch, mkSwitch+  , mkReturn, mkComment, mkCallEntry, mkBranch+  , mkUnwind+  , copyInOflow, copyOutOflow+  , noExtraStack+  , toCall, Transfer(..)+  )+where++import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)++import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.CallConv+import GHC.Cmm.Switch (SwitchTargets)++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import DynFlags+import FastString+import ForeignCall+import OrdList+import GHC.Runtime.Layout (ByteOff)+import UniqSupply+import Util+import Panic+++-----------------------------------------------------------------------------+-- Building Graphs+++-- | CmmAGraph is a chunk of code consisting of:+--+--   * ordinary statements (assignments, stores etc.)+--   * jumps+--   * labels+--   * out-of-line labelled blocks+--+-- The semantics is that control falls through labels and out-of-line+-- blocks.  Everything after a jump up to the next label is by+-- definition unreachable code, and will be discarded.+--+-- Two CmmAGraphs can be stuck together with <*>, with the meaning that+-- control flows from the first to the second.+--+-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)+-- by providing a label for the entry point and a tick scope; see+-- 'labelAGraph'.+type CmmAGraph = OrdList CgStmt+-- | Unlabeled graph with tick scope+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)++data CgStmt+  = CgLabel BlockId CmmTickScope+  | CgStmt  (CmmNode O O)+  | CgLast  (CmmNode O C)+  | CgFork  BlockId CmmAGraph CmmTickScope++flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph+flattenCmmAGraph id (stmts_t, tscope) =+    CmmGraph { g_entry = id,+               g_graph = GMany NothingO body NothingO }+  where+  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []++  --+  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.+  --+  -- NB. avoid the quadratic-append trap by passing in the tail of the+  -- list.  This is important for Very Long Functions (e.g. in T783).+  --+  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]+          -> [Block CmmNode C C]+  flatten id g tscope blocks+      = flatten1 (fromOL g) block' blocks+      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock+  --+  -- flatten0: we are outside a block at this point: any code before+  -- the first label is unreachable, so just drop it.+  --+  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]+  flatten0 [] blocks = blocks++  flatten0 (CgLabel id tscope : stmts) blocks+    = flatten1 stmts block blocks+    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock++  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks+    = flatten fork_id stmts_t tscope $ flatten0 rest blocks++  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks+  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks++  --+  -- flatten1: we have a partial block, collect statements until the+  -- next last node to make a block, then call flatten0 to get the rest+  -- of the blocks+  --+  flatten1 :: [CgStmt] -> Block CmmNode C O+           -> [Block CmmNode C C] -> [Block CmmNode C C]++  -- The current block falls through to the end of a function or fork:+  -- this code should not be reachable, but it may be referenced by+  -- other code that is not reachable.  We'll remove it later with+  -- dead-code analysis, but for now we have to keep the graph+  -- well-formed, so we terminate the block with a branch to the+  -- beginning of the current block.+  flatten1 [] block blocks+    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks++  flatten1 (CgLast stmt : stmts) block blocks+    = block' : flatten0 stmts blocks+    where !block' = blockJoinTail block stmt++  flatten1 (CgStmt stmt : stmts) block blocks+    = flatten1 stmts block' blocks+    where !block' = blockSnoc block stmt++  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks+    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks++  -- a label here means that we should start a new block, and the+  -- current block should fall through to the new block.+  flatten1 (CgLabel id tscp : stmts) block blocks+    = blockJoinTail block (CmmBranch id) :+      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks++++---------- AGraph manipulation++(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph+(<*>)           = appOL++catAGraphs     :: [CmmAGraph] -> CmmAGraph+catAGraphs      = concatOL++-- | creates a sequence "goto id; id:" as an AGraph+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph+mkLabel bid scp = unitOL (CgLabel bid scp)++-- | creates an open AGraph from a given node+mkMiddle        :: CmmNode O O -> CmmAGraph+mkMiddle middle = unitOL (CgStmt middle)++-- | creates a closed AGraph from a given node+mkLast         :: CmmNode O C -> CmmAGraph+mkLast last     = unitOL (CgLast last)++-- | A labelled code block; should end in a last node+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph+outOfLine l (c,s) = unitOL (CgFork l c s)++-- | allocate a fresh label for the entry point+lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph+lgraphOfAGraph g = do+  u <- getUniqueM+  return (labelAGraph (mkBlockId u) g)++-- | use the given BlockId as the label of the entry point+labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph+labelAGraph lbl ag = flattenCmmAGraph lbl ag++---------- No-ops+mkNop        :: CmmAGraph+mkNop         = nilOL++mkComment    :: FastString -> CmmAGraph+mkComment fs+  -- SDM: generating all those comments takes time, this saved about 4% for me+  | debugIsOn = mkMiddle $ CmmComment fs+  | otherwise = nilOL++---------- Assignment and store+mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph+mkAssign l (CmmReg r) | l == r  = mkNop+mkAssign l r  = mkMiddle $ CmmAssign l r++mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph+mkStore  l r  = mkMiddle $ CmmStore  l r++---------- Control transfer+mkJump          :: DynFlags -> Convention -> CmmExpr+                -> [CmmExpr]+                -> UpdFrameOffset+                -> CmmAGraph+mkJump dflags conv e actuals updfr_off =+  lastWithArgs dflags Jump Old conv actuals updfr_off $+    toCall e Nothing updfr_off 0++-- | A jump where the caller says what the live GlobalRegs are.  Used+-- for low-level hand-written Cmm.+mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+                -> CmmAGraph+mkRawJump dflags e updfr_off vols =+  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $+    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols+++mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]+                -> UpdFrameOffset -> [CmmExpr]+                -> CmmAGraph+mkJumpExtra dflags conv e actuals updfr_off extra_stack =+  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $+    toCall e Nothing updfr_off 0++mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph+mkCbranch pred ifso ifnot likely =+  mkLast (CmmCondBranch pred ifso ifnot likely)++mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph+mkSwitch e tbl   = mkLast $ CmmSwitch e tbl++mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset+                -> CmmAGraph+mkReturn dflags e actuals updfr_off =+  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $+    toCall e Nothing updfr_off 0++mkBranch        :: BlockId -> CmmAGraph+mkBranch bid     = mkLast (CmmBranch bid)++mkFinalCall   :: DynFlags+              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset+              -> CmmAGraph+mkFinalCall dflags f _ actuals updfr_off =+  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $+    toCall f Nothing updfr_off 0++mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+                -> BlockId+                -> ByteOff+                -> UpdFrameOffset+                -> [CmmExpr]+                -> CmmAGraph+mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do+  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals+     updfr_off extra_stack $+       toCall f (Just ret_lbl) updfr_off ret_off++-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be+-- already on the stack).+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+                -> BlockId+                -> ByteOff+                -> UpdFrameOffset+                -> CmmAGraph+mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do+  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $+       toCall f (Just ret_lbl) updfr_off ret_off++mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph+mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as++-- | Construct a 'CmmUnwind' node for the given register and unwinding+-- expression.+mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]++--------------------------------------------------------------------------+++++-- Why are we inserting extra blocks that simply branch to the successors?+-- Because in addition to the branch instruction, @mkBranch@ will insert+-- a necessary adjustment to the stack pointer.+++-- For debugging purposes, we can stub out dead stack slots:+stackStubExpr :: Width -> CmmExpr+stackStubExpr w = CmmLit (CmmInt 0 w)++-- When we copy in parameters, we usually want to put overflow+-- parameters on the stack, but sometimes we want to pass the+-- variables in their spill slots.  Therefore, for copying arguments+-- and results, we provide different functions to pass the arguments+-- in an overflow area and to pass them in spill slots.+copyInOflow  :: DynFlags -> Convention -> Area+             -> [CmmFormal]+             -> [CmmFormal]+             -> (Int, [GlobalReg], CmmAGraph)++copyInOflow dflags conv area formals extra_stk+  = (offset, gregs, catAGraphs $ map mkMiddle nodes)+  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk++-- Return the number of bytes used for copying arguments, as well as the+-- instructions to copy the arguments.+copyIn :: DynFlags -> Convention -> Area+       -> [CmmFormal]+       -> [CmmFormal]+       -> (ByteOff, [GlobalReg], [CmmNode O O])+copyIn dflags conv area formals extra_stk+  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))+  where+    -- See Note [Width of parameters]+    ci (reg, RegisterParam r@(VanillaReg {})) =+        let local = CmmLocal reg+            global = CmmReg (CmmGlobal r)+            width = cmmRegWidth dflags local+            expr+                | width == wordWidth dflags = global+                | width < wordWidth dflags =+                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]+                | otherwise = panic "Parameter width greater than word width"++        in CmmAssign local expr++    -- Non VanillaRegs+    ci (reg, RegisterParam r) =+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))++    ci (reg, StackParam off)+      | isBitsType $ localRegType reg+      , typeWidth (localRegType reg) < wordWidth dflags =+        let+          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))+          local = CmmLocal reg+          width = cmmRegWidth dflags local+          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]+        in CmmAssign local expr++      | otherwise =+         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)+         where ty = localRegType reg++    init_offset = widthInBytes (wordWidth dflags) -- infotable++    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk++    (stk_size, args) = assignArgumentsPos dflags stk_off conv+                                          localRegType formals++-- Factoring out the common parts of the copyout functions yielded something+-- more complicated:++data Transfer = Call | JumpRet | Jump | Ret deriving Eq++copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]+             -> UpdFrameOffset+             -> [CmmExpr] -- extra stack args+             -> (Int, [GlobalReg], CmmAGraph)++-- Generate code to move the actual parameters into the locations+-- required by the calling convention.  This includes a store for the+-- return address.+--+-- The argument layout function ignores the pointer to the info table,+-- so we slot that in here. When copying-out to a young area, we set+-- the info table for return and adjust the offsets of the other+-- parameters.  If this is a call instruction, we adjust the offsets+-- of the other parameters.+copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff+  = (stk_size, regs, graph)+  where+    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)++    -- See Note [Width of parameters]+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =+        let width = cmmExprWidth dflags v+            value+                | width == wordWidth dflags = v+                | width < wordWidth dflags =+                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]+                | otherwise = panic "Parameter width greater than word width"++        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)++    -- Non VanillaRegs+    co (v, RegisterParam r) (rs, ms) =+        (r:rs, mkAssign (CmmGlobal r) v <*> ms)++    -- See Note [Width of parameters]+    co (v, StackParam off)  (rs, ms)+      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)++    width v = cmmExprWidth dflags v+    value v+      | isBitsType $ cmmExprType dflags v+      , width v < wordWidth dflags =+        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]+      | otherwise = v++    (setRA, init_offset) =+      case area of+            Young id ->  -- Generate a store instruction for+                         -- the return address if making a call+                  case transfer of+                     Call ->+                       ([(CmmLit (CmmBlock id), StackParam init_offset)],+                       widthInBytes (wordWidth dflags))+                     JumpRet ->+                       ([],+                       widthInBytes (wordWidth dflags))+                     _other ->+                       ([], 0)+            Old -> ([], updfr_off)++    (extra_stack_off, stack_params) =+       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff++    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it+    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv+                                          (cmmExprType dflags) actuals+++-- Note [Width of parameters]+--+-- Consider passing a small (< word width) primitive like Int8# to a function.+-- It's actually non-trivial to do this without extending/narrowing:+-- * Global registers are considered to have native word width (i.e., 64-bits on+--   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a+--   global register.+-- * Same problem exists with LLVM IR.+-- * Lowering gets harder since on x86-32 not every register exposes its lower+--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding+--   8-bit register for %edi). So we would either need to extend/narrow anyway,+--   or complicate the calling convention.+-- * Passing a small integer in a stack slot, which has native word width,+--   requires extending to word width when writing to the stack and narrowing+--   when reading off the stack (see #16258).+-- So instead, we always extend every parameter smaller than native word width+-- in copyOutOflow and then truncate it back to the expected width in copyIn.+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring+-- zero-/sign-extending - it's up to a backend to handle this in a most+-- efficient way (e.g., a simple register move or a smaller size store).+-- This convention (of ignoring the upper bits) is different from some C ABIs,+-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.+--+-- There was some discussion about this on this PR:+-- https://github.com/ghc-proposals/ghc-proposals/pull/74+++mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]+            -> (Int, [GlobalReg], CmmAGraph)+mkCallEntry dflags conv formals extra_stk+  = copyInOflow dflags conv Old formals extra_stk++lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> CmmAGraph+lastWithArgs dflags transfer area conv actuals updfr_off last =+  lastWithArgsAndExtraStack dflags transfer area conv actuals+                            updfr_off noExtraStack last++lastWithArgsAndExtraStack :: DynFlags+             -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset -> [CmmExpr]+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> CmmAGraph+lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off+                          extra_stack last =+  copies <*> last outArgs regs+ where+  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals+                               updfr_off extra_stack+++noExtraStack :: [CmmExpr]+noExtraStack = []++toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff+       -> ByteOff -> [GlobalReg]+       -> CmmAGraph+toCall e cont updfr_off res_space arg_space regs =+  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
+ compiler/GHC/Cmm/Info.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE CPP #-}+module GHC.Cmm.Info (+  mkEmptyContInfoTable,+  cmmToRawCmm,+  mkInfoTable,+  srtEscape,++  -- info table accessors+  closureInfoPtr,+  entryCode,+  getConstrTag,+  cmmGetClosureType,+  infoTable,+  infoTableConstrTag,+  infoTableSrtBitmap,+  infoTableClosureType,+  infoTablePtrs,+  infoTableNonPtrs,+  funInfoTable,+  funInfoArity,++  -- info table sizes and offsets+  stdInfoTableSizeW,+  fixedInfoTableSizeW,+  profInfoTableSizeW,+  maxStdInfoTableSizeW,+  maxRetInfoTableSizeW,+  stdInfoTableSizeB,+  conInfoTableSizeB,+  stdSrtBitmapOffset,+  stdClosureTypeOffset,+  stdPtrsOffset, stdNonPtrsOffset,+) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Runtime.Layout+import GHC.Data.Bitmap+import Stream (Stream)+import qualified Stream+import GHC.Cmm.Dataflow.Collections++import GHC.Platform+import Maybes+import DynFlags+import ErrUtils (withTimingSilent)+import Panic+import UniqSupply+import MonadUtils+import Util+import Outputable++import Data.ByteString (ByteString)+import Data.Bits++-- When we split at proc points, we need an empty info table.+mkEmptyContInfoTable :: CLabel -> CmmInfoTable+mkEmptyContInfoTable info_lbl+  = CmmInfoTable { cit_lbl  = info_lbl+                 , cit_rep  = mkStackRep []+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a+            -> IO (Stream IO RawCmmGroup a)+cmmToRawCmm dflags cmms+  = do { uniqs <- mkSplitUniqSupply 'i'+       ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])+             do_one uniqs cmm =+               -- NB. strictness fixes a space leak.  DO NOT REMOVE.+               withTimingSilent dflags (text "Cmm -> Raw Cmm")+                                forceRes $+                 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of+                   (b,uniqs') -> return (uniqs',b)+       ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)+       }++    where forceRes (uniqs, rawcmms) =+            uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms++-- Make a concrete info table, represented as a list of CmmStatic+-- (it can't be simply a list of Word, because the SRT field is+-- represented by a label+offset expression).+--+-- With tablesNextToCode, the layout is+--      <reversed variable part>+--      <normal forward StgInfoTable, but without+--              an entry point at the front>+--      <code>+--+-- Without tablesNextToCode, the layout of an info table is+--      <entry label>+--      <normal forward rest of StgInfoTable>+--      <forward variable part>+--+--      See includes/rts/storage/InfoTables.h+--+-- For return-points these are as follows+--+-- Tables next to code:+--+--                      <srt slot>+--                      <standard info table>+--      ret-addr -->    <entry code (if any)>+--+-- Not tables-next-to-code:+--+--      ret-addr -->    <ptr to entry code>+--                      <standard info table>+--                      <srt slot>+--+--  * The SRT slot is only there if there is SRT info to record++mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]+mkInfoTable _ (CmmData sec dat)+  = return [CmmData sec dat]++mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)+  --+  -- in the non-tables-next-to-code case, procs can have at most a+  -- single info table associated with the entry label of the proc.+  --+  | not (tablesNextToCode dflags)+  = case topInfoTable proc of   --  must be at most one+      -- no info table+      Nothing ->+         return [CmmProc mapEmpty entry_lbl live blocks]++      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do+        (top_decls, (std_info, extra_bits)) <-+             mkInfoTableContents dflags info Nothing+        let+          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info+          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+        --+        -- Separately emit info table (with the function entry+        -- point as first entry) and the entry code+        --+        return (top_decls +++                [CmmProc mapEmpty entry_lbl live blocks,+                 mkRODataLits info_lbl+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])++  --+  -- With tables-next-to-code, we can have many info tables,+  -- associated with some of the BlockIds of the proc.  For each info+  -- table we need to turn it into CmmStatics, and collect any new+  -- CmmDecls that arise from doing so.+  --+  | otherwise+  = do+    (top_declss, raw_infos) <-+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))+    return (concat top_declss +++            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])++  where+   do_one_info (lbl,itbl) = do+     (top_decls, (std_info, extra_bits)) <-+         mkInfoTableContents dflags itbl Nothing+     let+        info_lbl = cit_lbl itbl+        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info+        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+     --+     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $+                              reverse rel_extra_bits ++ rel_std_info))++-----------------------------------------------------+type InfoTableContents = ( [CmmLit]          -- The standard part+                         , [CmmLit] )        -- The "extra bits"+-- These Lits have *not* had mkRelativeTo applied to them++mkInfoTableContents :: DynFlags+                    -> CmmInfoTable+                    -> Maybe Int               -- Override default RTS type tag?+                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls+                               InfoTableContents)       -- Info tbl + extra bits++mkInfoTableContents dflags+                    info@(CmmInfoTable { cit_lbl  = info_lbl+                                       , cit_rep  = smrep+                                       , cit_prof = prof+                                       , cit_srt = srt })+                    mb_rts_tag+  | RTSRep rts_tag rep <- smrep+  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)+    -- Completely override the rts_tag that mkInfoTableContents would+    -- otherwise compute, with the rts_tag stored in the RTSRep+    -- (which in turn came from a handwritten .cmm file)++  | StackRep frame <- smrep+  = do { (prof_lits, prof_data) <- mkProfLits dflags prof+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt+       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame+       ; let+             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit+             rts_tag | Just tag <- mb_rts_tag = tag+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits+                     | otherwise              = rET_BIG   -- Does not; extra_bits is+                                                          -- a label+       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }++  | HeapRep _ ptrs nonptrs closure_type <- smrep+  = do { let layout  = packIntsCLit dflags ptrs nonptrs+       ; (prof_lits, prof_data) <- mkProfLits dflags prof+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)+                                <- mk_pieces closure_type srt_label+       ; let std_info = mkStdInfoTable dflags prof_lits+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)+                                       (mb_srt_field `orElse` srt_bitmap)+                                       (mb_layout    `orElse` layout)+       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }+  where+    mk_pieces :: ClosureTypeInfo -> [CmmLit]+              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this+                        , Maybe CmmLit  -- Override the layout field with this+                        , [CmmLit]           -- "Extra bits" for info table+                        , [RawCmmDecl])      -- Auxiliary data decls+    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor+      = do { (descr_lit, decl) <- newStringLit con_descr+           ; return ( Just (CmmInt (fromIntegral con_tag)+                                   (halfWordWidth dflags))+                    , Nothing, [descr_lit], [decl]) }++    mk_pieces Thunk srt_label+      = return (Nothing, Nothing, srt_label, [])++    mk_pieces (ThunkSelector offset) _no_srt+      = return (Just (CmmInt 0 (halfWordWidth dflags)),+                Just (mkWordCLit dflags (fromIntegral offset)), [], [])+         -- Layout known (one free var); we use the layout field for offset++    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label+      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label+           ; return (Nothing, Nothing,  extra_bits, []) }++    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label+      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits+           ; let fun_type | null liveness_data = aRG_GEN+                          | otherwise          = aRG_GEN_BIG+                 extra_bits = [ packIntsCLit dflags fun_type arity ]+                           ++ (if inlineSRT dflags then [] else [ srt_lit ])+                           ++ [ liveness_lit, slow_entry ]+           ; return (Nothing, Nothing, extra_bits, liveness_data) }+      where+        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)+        srt_lit = case srt_label of+                    []          -> mkIntCLit dflags 0+                    (lit:_rest) -> ASSERT( null _rest ) lit++    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)++mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier++packIntsCLit :: DynFlags -> Int -> Int -> CmmLit+packIntsCLit dflags a b = packHalfWordsCLit dflags+                           (toStgHalfWord dflags (fromIntegral a))+                           (toStgHalfWord dflags (fromIntegral b))+++mkSRTLit :: DynFlags+         -> CLabel+         -> Maybe CLabel+         -> ([CmmLit],    -- srt_label, if any+             CmmLit)      -- srt_bitmap+mkSRTLit dflags info_lbl (Just lbl)+  | inlineSRT dflags+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))+++-- | Is the SRT offset field inline in the info table on this platform?+--+-- See the section "Referring to an SRT from the info table" in+-- Note [SRTs] in GHC.Cmm.Info.Build+inlineSRT :: DynFlags -> Bool+inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64+  && tablesNextToCode dflags++-------------------------------------------------------------------------+--+--      Lay out the info table and handle relative offsets+--+-------------------------------------------------------------------------++-- This function takes+--   * the standard info table portion (StgInfoTable)+--   * the "extra bits" (StgFunInfoExtraRev etc.)+--   * the entry label+--   * the code+-- and lays them out in memory, producing a list of RawCmmDecl++-------------------------------------------------------------------------+--+--      Position independent code+--+-------------------------------------------------------------------------+-- In order to support position independent code, we mustn't put absolute+-- references into read-only space. Info tables in the tablesNextToCode+-- case must be in .text, which is read-only, so we doctor the CmmLits+-- to use relative offsets instead.++-- Note that this is done even when the -fPIC flag is not specified,+-- as we want to keep binary compatibility between PIC and non-PIC.++makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit++makeRelativeRefTo dflags info_lbl (CmmLabel lbl)+  | tablesNextToCode dflags+  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)+  | tablesNextToCode dflags+  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)+makeRelativeRefTo _ _ lit = lit+++-------------------------------------------------------------------------+--+--              Build a liveness mask for the stack layout+--+-------------------------------------------------------------------------++-- There are four kinds of things on the stack:+--+--      - pointer variables (bound in the environment)+--      - non-pointer variables (bound in the environment)+--      - free slots (recorded in the stack free list)+--      - non-pointer data slots (recorded in the stack free list)+--+-- The first two are represented with a 'Just' of a 'LocalReg'.+-- The last two with one or more 'Nothing' constructors.+-- Each 'Nothing' represents one used word.+--+-- The head of the stack layout is the top of the stack and+-- the least-significant bit.++mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+              -- ^ Returns:+              --   1. The bitmap (literal value or label)+              --   2. Large bitmap CmmData if needed++mkLivenessBits dflags liveness+  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word+  = do { uniq <- getUniqueM+       ; let bitmap_lbl = mkBitmapLabel uniq+       ; return (CmmLabel bitmap_lbl,+                 [mkRODataLits bitmap_lbl lits]) }++  | otherwise -- Fits in one word+  = return (mkStgWordCLit dflags bitmap_word, [])+  where+    n_bits = length liveness++    bitmap :: Bitmap+    bitmap = mkBitmap dflags liveness++    small_bitmap = case bitmap of+                     []  -> toStgWord dflags 0+                     [b] -> b+                     _   -> panic "mkLiveness"+    bitmap_word = toStgWord dflags (fromIntegral n_bits)+              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)++    lits = mkWordCLit dflags (fromIntegral n_bits)+         : map (mkStgWordCLit dflags) bitmap+      -- The first word is the size.  The structure must match+      -- StgLargeBitmap in includes/rts/storage/InfoTable.h++-------------------------------------------------------------------------+--+--      Generating a standard info table+--+-------------------------------------------------------------------------++-- The standard bits of an info table.  This part of the info table+-- corresponds to the StgInfoTable type defined in+-- includes/rts/storage/InfoTables.h.+--+-- Its shape varies with ticky/profiling/tables next to code etc+-- so we can't use constant offsets from Constants++mkStdInfoTable+   :: DynFlags+   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)+   -> Int               -- Closure RTS tag+   -> CmmLit            -- SRT length+   -> CmmLit            -- layout field+   -> [CmmLit]++mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit+ =      -- Parallel revertible-black hole field+    prof_info+        -- Ticky info (none at present)+        -- Debug info (none at present)+ ++ [layout_lit, tag, srt]++ where+    prof_info+        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]+        | otherwise = []++    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)++-------------------------------------------------------------------------+--+--      Making string literals+--+-------------------------------------------------------------------------++mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])+mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])+mkProfLits _ (ProfilingInfo td cd)+  = do { (td_lit, td_decl) <- newStringLit td+       ; (cd_lit, cd_decl) <- newStringLit cd+       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }++newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)+newStringLit bytes+  = do { uniq <- getUniqueM+       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }+++-- Misc utils++-- | Value of the srt field of an info table when using an StgLargeSRT+srtEscape :: DynFlags -> StgHalfWord+srtEscape dflags = toStgHalfWord dflags (-1)++-------------------------------------------------------------------------+--+--      Accessing fields of an info table+--+-------------------------------------------------------------------------++-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is+-- enabled.+wordAligned :: DynFlags -> CmmExpr -> CmmExpr+wordAligned dflags e+  | gopt Opt_AlignmentSanitisation dflags+  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]+  | otherwise+  = e++closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer and returns the info table pointer+closureInfoPtr dflags e =+    CmmLoad (wordAligned dflags e) (bWord dflags)++entryCode :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info pointer (the first word of a closure)+-- and returns its entry code+entryCode dflags e+ | tablesNextToCode dflags = e+ | otherwise               = CmmLoad e (bWord dflags)++getConstrTag :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer, and return the *zero-indexed*+-- constructor tag obtained from the info table+-- This lives in the SRT field of the info table+-- (constructors don't need SRTs).+getConstrTag dflags closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]+  where+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)++cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer, and return the closure type+-- obtained from the info table+cmmGetClosureType dflags closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]+  where+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)++infoTable :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info pointer (the first word of a closure)+-- and returns a pointer to the first word of the standard-form+-- info table, excluding the entry-code word (if present)+infoTable dflags info_ptr+  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)+  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer++infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the constr tag+-- field of the info table (same as the srt_bitmap field)+infoTableConstrTag = infoTableSrtBitmap++infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap+-- field of the info table+infoTableSrtBitmap dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)++infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the closure type+-- field of the info table.+infoTableClosureType dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)++infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr+infoTablePtrs dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)++infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr+infoTableNonPtrs dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)++funInfoTable :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the info pointer of a function,+-- and returns a pointer to the first word of the StgFunInfoExtra struct+-- in the info table.+funInfoTable dflags info_ptr+  | tablesNextToCode dflags+  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)+  | otherwise+  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)+                                -- Past the entry code pointer++-- Takes the info pointer of a function, returns the function's arity+funInfoArity :: DynFlags -> CmmExpr -> CmmExpr+funInfoArity dflags iptr+  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))+  where+   fun_info = funInfoTable dflags iptr+   rep = cmmBits (widthFromBytes rep_bytes)++   (rep_bytes, offset)+    | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc+                                , oFFSET_StgFunInfoExtraRev_arity dflags )+    | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc+                                , oFFSET_StgFunInfoExtraFwd_arity dflags )++   pc = platformConstants dflags++-----------------------------------------------------------------------------+--+--      Info table sizes & offsets+--+-----------------------------------------------------------------------------++stdInfoTableSizeW :: DynFlags -> WordOff+-- The size of a standard info table varies with profiling/ticky etc,+-- so we can't get it from Constants+-- It must vary in sync with mkStdInfoTable+stdInfoTableSizeW dflags+  = fixedInfoTableSizeW+  + if gopt Opt_SccProfilingOn dflags+       then profInfoTableSizeW+       else 0++fixedInfoTableSizeW :: WordOff+fixedInfoTableSizeW = 2 -- layout, type++profInfoTableSizeW :: WordOff+profInfoTableSizeW = 2++maxStdInfoTableSizeW :: WordOff+maxStdInfoTableSizeW =+  1 {- entry, when !tablesNextToCode -}+  + fixedInfoTableSizeW+  + profInfoTableSizeW++maxRetInfoTableSizeW :: WordOff+maxRetInfoTableSizeW =+  maxStdInfoTableSizeW+  + 1 {- srt label -}++stdInfoTableSizeB  :: DynFlags -> ByteOff+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags++stdSrtBitmapOffset :: DynFlags -> ByteOff+-- Byte offset of the SRT bitmap half-word which is+-- in the *higher-addressed* part of the type_lit+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags++stdClosureTypeOffset :: DynFlags -> ByteOff+-- Byte offset of the closure type half-word+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags++stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags++conInfoTableSizeB :: DynFlags -> Int+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
+ compiler/GHC/Cmm/Info/Build.hs view
@@ -0,0 +1,892 @@+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}++module GHC.Cmm.Info.Build+  ( CAFSet, CAFEnv, cafAnal+  , doSRTs, ModuleSRTInfo, emptySRT+  ) where++import GhcPrelude hiding (succ)++import Id+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow+import Module+import GHC.Platform+import Digraph+import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Cmm.Utils+import DynFlags+import Maybes+import Outputable+import GHC.Runtime.Layout+import UniqSupply+import CostCentre+import GHC.StgToCmm.Heap++import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Tuple+import Control.Monad.Trans.State+import Control.Monad.Trans.Class+++{- Note [SRTs]++SRTs are the mechanism by which the garbage collector can determine+the live CAFs in the program.++Representation+^^^^^^^^^^^^^^+++------++| info |+|      |     +-----+---+---+---++|   -------->|SRT_2| | | | | 0 |+|------|     +-----+-|-+-|-+---++|      |             |   |+| code |             |   |+|      |             v   v++An SRT is simply an object in the program's data segment. It has the+same representation as a static constructor.  There are 16+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,+representing SRT objects with 1-16 pointers, respectively.++The entries of an SRT object point to static closures, which are either+- FUN_STATIC, THUNK_STATIC or CONSTR+- Another SRT (actually just a CONSTR)++The final field of the SRT is the static link field, used by the+garbage collector to chain together static closures that it visits and+to determine whether a static closure has been visited or not. (see+Note [STATIC_LINK fields])++By traversing the transitive closure of an SRT, the GC will reach all+of the CAFs that are reachable from the code associated with this SRT.++If we need to create an SRT with more than 16 entries, we build a+chain of SRT objects with all but the last having 16 entries.+++-----+---+- -+---+---++|SRT16| | |   | | | 0 |++-----+-|-+- -+-|-+---++        |       |+        v       v+              +----+---+---+---++              |SRT2| | | | | 0 |+              +----+-|-+-|-+---++                     |   |+                     |   |+                     v   v++Referring to an SRT from the info table+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++The following things have SRTs:++- Static functions (FUN)+- Static thunks (THUNK), ie. CAFs+- Continuations (RET_SMALL, etc.)++In each case, the info table points to the SRT.++- info->srt is zero if there's no SRT, otherwise:+- info->srt == 1 and info->f.srt_offset points to the SRT++e.g. for a FUN with an SRT:++StgFunInfoTable       +------++  info->f.srt_offset  |  ------------> offset to SRT object+StgStdInfoTable       +------++  info->layout.ptrs   | ...  |+  info->layout.nptrs  | ...  |+  info->srt           |  1   |+  info->type          | ...  |+                      |------|++On x86_64, we optimise the info table representation further.  The+offset to the SRT can be stored in 32 bits (all code lives within a+2GB region in x86_64's small memory model), so we can save a word in+the info table by storing the srt_offset in the srt field, which is+half a word.++On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):++- info->srt is zero if there's no SRT, otherwise:+- info->srt is an offset from the info pointer to the SRT object++StgStdInfoTable       +------++  info->layout.ptrs   |      |+  info->layout.nptrs  |      |+  info->srt           |  ------------> offset to SRT object+                      |------|+++EXAMPLE+^^^^^^^++f = \x. ... g ...+  where+    g = \y. ... h ... c1 ...+    h = \z. ... c2 ...++c1 & c2 are CAFs++g and h are local functions, but they have no static closures.  When+we generate code for f, we start with a CmmGroup of four CmmDecls:++   [ f_closure, f_entry, g_entry, h_entry ]++we process each CmmDecl separately in cpsTop, giving us a list of+CmmDecls. e.g. for f_entry, we might end up with++   [ f_entry, f1_ret, f2_proc ]++where f1_ret is a return point, and f2_proc is a proc-point.  We have+a CAFSet for each of these CmmDecls, let's suppose they are++   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]+   [ g_entry{h_info, c1_closure} ]+   [ h_entry{c2_closure} ]++Next, we make an SRT for each of these functions:++  f_srt : [g_info]+  g_srt : [h_info, c1_closure]+  h_srt : [c2_closure]++Now, for g_info and h_info, we want to refer to the SRTs for g and h+respectively, which we'll label g_srt and h_srt:++  f_srt : [g_srt]+  g_srt : [h_srt, c1_closure]+  h_srt : [c2_closure]++Now, when an SRT has a single entry, we don't actually generate an SRT+closure for it, instead we just replace references to it with its+single element.  So, since h_srt == c2_closure, we have++  f_srt : [g_srt]+  g_srt : [c2_closure, c1_closure]+  h_srt : [c2_closure]++and the only SRT closure we generate is++  g_srt = SRT_2 [c2_closure, c1_closure]+++Optimisations+^^^^^^^^^^^^^++To reduce the code size overhead and the cost of traversing SRTs in+the GC, we want to simplify SRTs where possible. We therefore apply+the following optimisations.  Each has a [keyword]; search for the+keyword in the code below to see where the optimisation is+implemented.++1. [Inline] we never create an SRT with a single entry, instead we+   point to the single entry directly from the info table.++   i.e. instead of++    +------++    | info |+    |      |     +-----+---+---++    |   -------->|SRT_1| | | 0 |+    |------|     +-----+-|-+---++    |      |             |+    | code |             |+    |      |             v+                         C++   we can point directly to the closure:++    +------++    | info |+    |      |+    |   -------->C+    |------|+    |      |+    | code |+    |      |+++   Furthermore, the SRT for any code that refers to this info table+   can point directly to C.++   The exception to this is when we're doing dynamic linking. In that+   case, if the closure is not locally defined then we can't point to+   it directly from the info table, because this is the text section+   which cannot contain runtime relocations. In this case we skip this+   optimisation and generate the singleton SRT, because SRTs are in the+   data section and *can* have relocatable references.++2. [FUN] A static function closure can also be an SRT, we simply put+   the SRT entries as fields in the static closure.  This makes a lot+   of sense: the static references are just like the free variables of+   the FUN closure.++   i.e. instead of++   f_closure:+   +-----+---++   |  |  | 0 |+   +- |--+---++      |            +------++      |            | info |     f_srt:+      |            |      |     +-----+---+---+---++      |            |   -------->|SRT_2| | | | + 0 |+      `----------->|------|     +-----+-|-+-|-+---++                   |      |             |   |+                   | code |             |   |+                   |      |             v   v+++   We can generate:++   f_closure:+   +-----+---+---+---++   |  |  | | | | | 0 |+   +- |--+-|-+-|-+---++      |    |   |   +------++      |    v   v   | info |+      |            |      |+      |            |   0  |+      `----------->|------|+                   |      |+                   | code |+                   |      |+++   (note: we can't do this for THUNKs, because the thunk gets+   overwritten when it is entered, so we wouldn't be able to share+   this SRT with other info tables that want to refer to it (see+   [Common] below). FUNs are immutable so don't have this problem.)++3. [Common] Identical SRTs can be commoned up.++4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also+   refers to C (perhaps transitively), then we can omit the reference+   to C from A.+++Note that there are many other optimisations that we could do, but+aren't implemented. In general, we could omit any reference from an+SRT if everything reachable from it is also reachable from the other+fields in the SRT. Our [Filter] optimisation is a special case of+this.++Another opportunity we don't exploit is this:++A = {X,Y,Z}+B = {Y,Z}+C = {X,B}++Here we could use C = {A} and therefore [Inline] C = A.+-}++-- ---------------------------------------------------------------------+{- Note [Invalid optimisation: shortcutting]++You might think that if we have something like++A's SRT = {B}+B's SRT = {X}++that we could replace the reference to B in A's SRT with X.++A's SRT = {X}+B's SRT = {X}++and thereby perhaps save a little work at runtime, because we don't+have to visit B.++But this is NOT valid.++Consider these cases:++0. B can't be a constructor, because constructors don't have SRTs++1. B is a CAF. This is the easy one. Obviously we want A's SRT to+   point to B, so that it keeps B alive.++2. B is a function.  This is the tricky one. The reason we can't+shortcut in this case is that we aren't allowed to resurrect static+objects.++== How does this cause a problem? ==++The particular case that cropped up when we tried this was #15544.+- A is a thunk+- B is a static function+- X is a CAF+- suppose we GC when A is alive, and B is not otherwise reachable.+- B is "collected", meaning that it doesn't make it onto the static+  objects list during this GC, but nothing bad happens yet.+- Next, suppose we enter A, and then call B. (remember that A refers to B)+  At the entry point to B, we GC. This puts B on the stack, as part of the+  RET_FUN stack frame that gets pushed when we GC at a function entry point.+- This GC will now reach B+- But because B was previous "collected", it breaks the assumption+  that static objects are never resurrected. See Note [STATIC_LINK+  fields] in rts/sm/Storage.h for why this is bad.+- In practice, the GC thinks that B has already been visited, and so+  doesn't visit X, and catastrophe ensues.++== Isn't this caused by the RET_FUN business? ==++Maybe, but could you prove that RET_FUN is the only way that+resurrection can occur?++So, no shortcutting.+-}++-- ---------------------------------------------------------------------+-- Label types++-- Labels that come from cafAnal can be:+--   - _closure labels for static functions or CAFs+--   - _info labels for dynamic functions, thunks, or continuations+--   - _entry labels for functions or thunks+--+-- Meanwhile the labels on top-level blocks are _entry labels.+--+-- To put everything in the same namespace we convert all labels to+-- closure labels using toClosureLbl.  Note that some of these+-- labels will not actually exist; that's ok because we're going to+-- map them to SRTEntry later, which ranges over labels that do exist.+--+newtype CAFLabel = CAFLabel CLabel+  deriving (Eq,Ord,Outputable)++type CAFSet = Set CAFLabel+type CAFEnv = LabelMap CAFSet++mkCAFLabel :: CLabel -> CAFLabel+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)++-- This is a label that we can put in an SRT.  It *must* be a closure label,+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.+newtype SRTEntry = SRTEntry CLabel+  deriving (Eq, Ord, Outputable)++-- ---------------------------------------------------------------------+-- CAF analysis++-- |+-- For each code block:+--   - collect the references reachable from this code block to FUN,+--     THUNK or RET labels for which hasCAF == True+--+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels+--+cafAnal+  :: LabelSet   -- The blocks representing continuations, ie. those+                -- that will get RET info tables.  These labels will+                -- get their own SRTs, so we don't aggregate CAFs from+                -- references to these labels, we just use the label.+  -> CLabel     -- The top label of the proc+  -> CmmGraph+  -> CAFEnv+cafAnal contLbls topLbl cmmGraph =+  analyzeCmmBwd cafLattice+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty+++cafLattice :: DataflowLattice CAFSet+cafLattice = DataflowLattice Set.empty add+  where+    add (OldFact old) (NewFact new) =+        let !new' = old `Set.union` new+        in changedIf (Set.size new' > Set.size old) new'+++cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet+cafTransfers contLbls entry topLbl+  (BlockCC eNode middle xNode) fBase =+    let joined = cafsInNode xNode $! live'+        !result = foldNodesBwdOO cafsInNode middle joined++        facts = mapMaybe successorFact (successors xNode)+        live' = joinFacts cafLattice facts++        successorFact s+          -- If this is a loop back to the entry, we can refer to the+          -- entry label.+          | s == entry = Just (add topLbl Set.empty)+          -- If this is a continuation, we want to refer to the+          -- SRT for the continuation's info table+          | s `setMember` contLbls+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))+          -- Otherwise, takes the CAF references from the destination+          | otherwise+          = lookupFact s fBase++        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet+        cafsInNode node set = foldExpDeep addCaf node set++        addCaf expr !set =+          case expr of+              CmmLit (CmmLabel c) -> add c set+              CmmLit (CmmLabelOff c _) -> add c set+              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set+              _ -> set+        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s+                | otherwise = s++    in mapSingleton (entryLabel eNode) result+++-- -----------------------------------------------------------------------------+-- ModuleSRTInfo++data ModuleSRTInfo = ModuleSRTInfo+  { thisModule :: Module+    -- ^ Current module being compiled. Required for calling labelDynamic.+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry+    -- ^ previous SRTs we've emitted, so we can de-duplicate.+    -- Used to implement the [Common] optimisation.+  , flatSRTs :: Map SRTEntry (Set SRTEntry)+    -- ^ The reverse mapping, so that we can remove redundant+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b+    -- points to [c,d], we can omit c and emit [a,b].+    -- Used to implement the [Filter] optimisation.+  }+instance Outputable ModuleSRTInfo where+  ppr ModuleSRTInfo{..} =+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs++emptySRT :: Module -> ModuleSRTInfo+emptySRT mod =+  ModuleSRTInfo+    { thisModule = mod+    , dedupSRTs = Map.empty+    , flatSRTs = Map.empty }++-- -----------------------------------------------------------------------------+-- Constructing SRTs++{- Implementation notes++- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable++- The entry in info_tbls corresponding to g_entry is the closure info+  table, the rest are continuations.++- Each entry in info_tbls possibly needs an SRT.  We need to make a+  label for each of these.++- We get the CAFSet for each entry from the CAFEnv++-}++-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,+--   where the label is+--   - the info label for a continuation or dynamic closure+--   - the closure label for a top-level function (not a CAF)+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]+getLabelledBlocks (CmmData _ _) = []+getLabelledBlocks (CmmProc top_info _ _ _) =+  [ (blockId, mkCAFLabel (cit_lbl info))+  | (blockId, info) <- mapToList (info_tbls top_info)+  , let rep = cit_rep info+  , not (isStaticRep rep) || not (isThunkRep rep)+  ]+++-- | Put the labelled blocks that we will be annotating with SRTs into+-- dependency order.  This is so that we can process them one at a+-- time, resolving references to earlier blocks to point to their+-- SRTs. CAFs themselves are not included here; see getCAFs below.+depAnalSRTs+  :: CAFEnv+  -> [CmmDecl]+  -> [SCC (Label, CAFLabel, Set CAFLabel)]+depAnalSRTs cafEnv decls =+  srtTrace "depAnalSRTs" (ppr graph) graph+ where+  labelledBlocks = concatMap getLabelledBlocks decls+  labelToBlock = Map.fromList (map swap labelledBlocks)+  graph = stronglyConnCompFromEdgedVerticesOrd+             [ let cafs' = Set.delete lbl cafs in+               DigraphNode (l,lbl,cafs') l+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))+             | (l, lbl) <- labelledBlocks+             , Just cafs <- [mapLookup l cafEnv] ]+++-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.+-- These are treated differently from other labelled blocks:+--  - we never shortcut a reference to a CAF to the contents of its+--    SRT, since the point of SRTs is to keep CAFs alive.+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.+--    instead we generate their SRTs after everything else.+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]+getCAFs cafEnv decls =+  [ (g_entry g, mkCAFLabel topLbl, cafs)+  | CmmProc top_info topLbl _ g <- decls+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]+  , let rep = cit_rep info+  , isStaticRep rep && isThunkRep rep+  , Just cafs <- [mapLookup (g_entry g) cafEnv]+  ]+++-- | Get the list of blocks that correspond to the entry points for+-- FUN_STATIC closures.  These are the blocks for which if we have an+-- SRT we can merge it with the static closure. [FUN]+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]+getStaticFuns decls =+  [ (g_entry g, lbl)+  | CmmProc top_info _ _ g <- decls+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]+  , Just (id, _) <- [cit_clo info]+  , let rep = cit_rep info+  , isStaticRep rep && isFunRep rep+  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+  ]+++-- | Maps labels from 'cafAnal' to the final CLabel that will appear+-- in the SRT.+--   - closures with singleton SRTs resolve to their single entry+--   - closures with larger SRTs map to the label for that SRT+--   - CAFs must not map to anything!+--   - if a labels maps to Nothing, we found that this label's SRT+--     is empty, so we don't need to refer to it from other SRTs.+type SRTMap = Map CAFLabel (Maybe SRTEntry)++-- | resolve a CAFLabel to its SRTEntry using the SRTMap+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry+resolveCAF srtMap lbl@(CAFLabel l) =+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap+++-- | Attach SRTs to all info tables in the CmmDecls, and add SRT+-- declarations to the ModuleSRTInfo.+--+doSRTs+  :: DynFlags+  -> ModuleSRTInfo+  -> [(CAFEnv, [CmmDecl])]+  -> IO (ModuleSRTInfo, [CmmDecl])++doSRTs dflags moduleSRTInfo tops = do+  us <- mkSplitUniqSupply 'u'++  -- Ignore the original grouping of decls, and combine all the+  -- CAFEnvs into a single CAFEnv.+  let (cafEnvs, declss) = unzip tops+      cafEnv = mapUnions cafEnvs+      decls = concat declss+      staticFuns = mapFromList (getStaticFuns decls)++  -- Put the decls in dependency order. Why? So that we can implement+  -- [Inline] and [Filter].  If we need to refer to an SRT that has+  -- a single entry, we use the entry itself, which means that we+  -- don't need to generate the singleton SRT in the first place.  But+  -- to do this we need to process blocks before things that depend on+  -- them.+  let+    sccs = depAnalSRTs cafEnv decls+    cafsWithSRTs = getCAFs cafEnv decls++  -- On each strongly-connected group of decls, construct the SRT+  -- closures and the SRT fields for info tables.+  let result ::+        [ ( [CmmDecl]              -- generated SRTs+          , [(Label, CLabel)]      -- SRT fields for info tables+          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions+          ) ]+      ((result, _srtMap), moduleSRTInfo') =+        initUs_ us $+        flip runStateT moduleSRTInfo $+        flip runStateT Map.empty $ do+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs+          return (nonCAFs ++ cAFs)++      (declss, pairs, funSRTs) = unzip3 result++  -- Next, update the info tables with the SRTs+  let+    srtFieldMap = mapFromList (concat pairs)+    funSRTMap = mapFromList (concat funSRTs)+    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls++  return (moduleSRTInfo', concat declss ++ decls')+++-- | Build the SRT for a strongly-connected component of blocks+doSCC+  :: DynFlags+  -> LabelMap CLabel           -- which blocks are static function entry points+  -> SCC (Label, CAFLabel, Set CAFLabel)+  -> StateT SRTMap+        (StateT ModuleSRTInfo UniqSM)+        ( [CmmDecl]              -- generated SRTs+        , [(Label, CLabel)]      -- SRT fields for info tables+        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions+        )++doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =+  oneSRT dflags staticFuns [l] [cafLbl] False cafs++doSCC dflags staticFuns (CyclicSCC nodes) = do+  -- build a single SRT for the whole cycle, see Note [recursive SRTs]+  let (blockids, lbls, cafsets) = unzip3 nodes+      cafs = Set.unions cafsets+  oneSRT dflags staticFuns blockids lbls False cafs+++{- Note [recursive SRTs]++If the dependency analyser has found us a recursive group of+declarations, then we build a single SRT for the whole group, on the+grounds that everything in the group is reachable from everything+else, so we lose nothing by having a single SRT.++However, there are a couple of wrinkles to be aware of.++* The Set CAFLabel for this SRT will contain labels in the group+itself. The SRTMap will therefore not contain entries for these labels+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we+can just remove recursive references from the Set CAFLabel before+generating the SRT - the SRT will still contain all the CAFLabels that+we need to refer to from this group's SRT.++* That is, EXCEPT for static function closures. For the same reason+described in Note [Invalid optimisation: shortcutting], we cannot omit+references to static function closures.+  - But, since we will merge the SRT with one of the static function+    closures (see [FUN]), we can omit references to *that* static+    function closure from the SRT.+-}++-- | Build an SRT for a set of blocks+oneSRT+  :: DynFlags+  -> LabelMap CLabel            -- which blocks are static function entry points+  -> [Label]                    -- blocks in this set+  -> [CAFLabel]                 -- labels for those blocks+  -> Bool                       -- True <=> this SRT is for a CAF+  -> Set CAFLabel               -- SRT for this set+  -> StateT SRTMap+       (StateT ModuleSRTInfo UniqSM)+       ( [CmmDecl]                    -- SRT objects we built+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls+       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions+       )++oneSRT dflags staticFuns blockids lbls isCAF cafs = do+  srtMap <- get+  topSRT <- lift get+  let+    -- Can we merge this SRT with a FUN_STATIC closure?+    (maybeFunClosure, otherFunLabels) =+      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of+        [] -> (Nothing, [])+        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)++    -- Remove recursive references from the SRT, except for (all but+    -- one of the) static functions. See Note [recursive SRTs].+    nonRec = cafs `Set.difference`+      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)++    -- First resolve all the CAFLabels to SRTEntries+    -- Implements the [Inline] optimisation.+    resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)++    -- The set of all SRTEntries in SRTs that we refer to from here.+    allBelow =+      Set.unions [ lbls | caf <- resolved+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]++    -- Remove SRTEntries that are also in an SRT that we refer to.+    -- Implements the [Filter] optimisation.+    filtered = Set.difference (Set.fromList resolved) allBelow++  srtTrace "oneSRT:"+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()++  let+    isStaticFun = isJust maybeFunClosure++    -- For a label without a closure (e.g. a continuation), we must+    -- update the SRTMap for the label to point to a closure. It's+    -- important that we don't do this for static functions or CAFs,+    -- see Note [Invalid optimisation: shortcutting].+    updateSRTMap srtEntry =+      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]+        put (Map.union newSRTMap srtMap)++    this_mod = thisModule topSRT++  case Set.toList filtered of+    [] -> do+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()+      updateSRTMap Nothing+      return ([], [], [])++    -- [Inline] - when we have only one entry there is no need to+    -- build an SRT object at all, instead we put the singleton SRT+    -- entry in the info table.+    [one@(SRTEntry lbl)]+      | -- Info tables refer to SRTs by offset (as noted in the section+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,+        -- when dynamic linking is used we cannot guarantee that the offset+        -- between the SRT and the info table will fit in the offset field.+        -- Consequently we build a singleton SRT in in this case.+        not (labelDynamic dflags this_mod lbl)++        -- MachO relocations can't express offsets between compilation units at+        -- all, so we are always forced to build a singleton SRT in this case.+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)+             || isLocalCLabel this_mod lbl) -> do++        -- If we have a static function closure, then it becomes the+        -- SRT object, and everything else points to it. (the only way+        -- we could have multiple labels here is if this is a+        -- recursive group, see Note [recursive SRTs])+        case maybeFunClosure of+          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])+            where+              withLabels =+                [ (b, if b == staticFunBlock then lbl else staticFunLbl)+                | b <- blockids ]+          Nothing -> do+            updateSRTMap (Just one)+            return ([], map (,lbl) blockids, [])++    cafList ->+      -- Check whether an SRT with the same entries has been emitted already.+      -- Implements the [Common] optimisation.+      case Map.lookup filtered (dedupSRTs topSRT) of+        Just srtEntry@(SRTEntry srtLbl)  -> do+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()+          updateSRTMap (Just srtEntry)+          return ([], map (,srtLbl) blockids, [])+        Nothing -> do+          -- No duplicates: we have to build a new SRT object+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()+          (decls, funSRTs, srtEntry) <-+            case maybeFunClosure of+              Just (fun,block) ->+                return ( [], [(block, cafList)], SRTEntry fun )+              Nothing -> do+                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList+                return (decls, [], entry)+          updateSRTMap (Just srtEntry)+          let allBelowThis = Set.union allBelow filtered+              oldFlatSRTs = flatSRTs topSRT+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)+          lift (put (topSRT { dedupSRTs = newDedupSRTs+                            , flatSRTs = newFlatSRTs }))+          let SRTEntry lbl = srtEntry+          return (decls, map (,lbl) blockids, funSRTs)+++-- | build a static SRT object (or a chain of objects) from a list of+-- SRTEntries.+buildSRTChain+   :: DynFlags+   -> [SRTEntry]+   -> UniqSM+        ( [CmmDecl]    -- The SRT object(s)+        , SRTEntry     -- label to use in the info table+        )+buildSRTChain _ [] = panic "buildSRT: empty"+buildSRTChain dflags cafSet =+  case splitAt mAX_SRT_SIZE cafSet of+    (these, []) -> do+      (decl,lbl) <- buildSRT dflags these+      return ([decl], lbl)+    (these,those) -> do+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)+      return (decl:rest, lbl)+  where+    mAX_SRT_SIZE = 16+++buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)+buildSRT dflags refs = do+  id <- getUniqueM+  let+    lbl = mkSRTLabel id+    srt_n_info = mkSRTInfoLabel (length refs)+    fields =+      mkStaticClosure dflags srt_n_info dontCareCCS+        [ CmmLabel lbl | SRTEntry lbl <- refs ]+        [] -- no padding+        [mkIntCLit dflags 0] -- link field+        [] -- no saved info+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)+++-- | Update info tables with references to their SRTs. Also generate+-- static closures, splicing in SRT fields as necessary.+updInfoSRTs+  :: DynFlags+  -> LabelMap CLabel               -- SRT labels for each block+  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures+  -> CmmDecl+  -> [CmmDecl]++updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)+  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]+  | otherwise = [ proc ]+  where+    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g+    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)+    updInfoTbl l info_tbl+      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf+      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }++    -- Generate static closures [FUN].  Note that this also generates+    -- static closures for thunks (CAFs), because it's easier to treat+    -- them uniformly in the code generator.+    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)+    maybeStaticClosure+      | Just info_tbl@CmmInfoTable{..} <-+           mapLookup (g_entry g) (info_tbls top_info)+      , Just (id, ccs) <- cit_clo+      , isStaticRep cit_rep =+        let+          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of+            Nothing ->+              -- if we don't add SRT entries to this closure, then we+              -- want to set the srt field in its info table as usual+              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])+            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)+              (info_tbl { cit_rep = new_rep }, res)+              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]+          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)+            srtEntries+          new_rep = case cit_rep of+             HeapRep sta ptrs nptrs ty ->+               HeapRep sta (ptrs + length srtEntries) nptrs ty+             _other -> panic "maybeStaticFun"+          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+        in+          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)+      | otherwise = Nothing++updInfoSRTs _ _ _ t = [t]+++srtTrace :: String -> SDoc -> b -> b+-- srtTrace = pprTrace+srtTrace _ _ b = b
+ compiler/GHC/Cmm/LayoutStack.hs view
@@ -0,0 +1,1236 @@+{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}+module GHC.Cmm.LayoutStack (+       cmmLayoutStack, setInfoTableStackMap+  ) where++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation+import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation++import BasicTypes+import GHC.Cmm+import GHC.Cmm.Info+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Utils+import GHC.Cmm.Graph+import ForeignCall+import GHC.Cmm.Liveness+import GHC.Cmm.ProcPoint+import GHC.Runtime.Layout+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import UniqSupply+import Maybes+import UniqFM+import Util++import DynFlags+import FastString+import Outputable hiding ( isEmpty )+import qualified Data.Set as Set+import Control.Monad.Fix+import Data.Array as Array+import Data.Bits+import Data.List (nub)++{- Note [Stack Layout]++The job of this pass is to++ - replace references to abstract stack Areas with fixed offsets from Sp.++ - replace the CmmHighStackMark constant used in the stack check with+   the maximum stack usage of the proc.++ - save any variables that are live across a call, and reload them as+   necessary.++Before stack allocation, local variables remain live across native+calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local+variables are clobbered by native calls.++We want to do stack allocation so that as far as possible+ - stack use is minimized, and+ - unnecessary stack saves and loads are avoided.++The algorithm we use is a variant of linear-scan register allocation,+where the stack is our register file.++We proceed in two passes, see Note [Two pass approach] for why they are not easy+to merge into one.++Pass 1:++ - First, we do a liveness analysis, which annotates every block with+   the variables live on entry to the block.++ - We traverse blocks in reverse postorder DFS; that is, we visit at+   least one predecessor of a block before the block itself.  The+   stack layout flowing from the predecessor of the block will+   determine the stack layout on entry to the block.++ - We maintain a data structure++     Map Label StackMap++   which describes the contents of the stack and the stack pointer on+   entry to each block that is a successor of a block that we have+   visited.++ - For each block we visit:++    - Look up the StackMap for this block.++    - If this block is a proc point (or a call continuation, if we aren't+      splitting proc points), we need to reload all the live variables from the+      stack - but this is done in Pass 2, which calculates more precise liveness+      information (see description of Pass 2).++    - Walk forwards through the instructions:+      - At an assignment  x = Sp[loc]+        - Record the fact that Sp[loc] contains x, so that we won't+          need to save x if it ever needs to be spilled.+      - At an assignment  x = E+        - If x was previously on the stack, it isn't any more+      - At the last node, if it is a call or a jump to a proc point+        - Lay out the stack frame for the call (see setupStackFrame)+        - emit instructions to save all the live variables+        - Remember the StackMaps for all the successors+        - emit an instruction to adjust Sp+      - If the last node is a branch, then the current StackMap is the+        StackMap for the successors.++    - Manifest Sp: replace references to stack areas in this block+      with real Sp offsets. We cannot do this until we have laid out+      the stack area for the successors above.++      In this phase we also eliminate redundant stores to the stack;+      see elimStackStores.++  - There is one important gotcha: sometimes we'll encounter a control+    transfer to a block that we've already processed (a join point),+    and in that case we might need to rearrange the stack to match+    what the block is expecting. (exactly the same as in linear-scan+    register allocation, except here we have the luxury of an infinite+    supply of temporary variables).++  - Finally, we update the magic CmmHighStackMark constant with the+    stack usage of the function, and eliminate the whole stack check+    if there was no stack use. (in fact this is done as part of the+    main traversal, by feeding the high-water-mark output back in as+    an input. I hate cyclic programming, but it's just too convenient+    sometimes.)++  There are plenty of tricky details: update frames, proc points, return+  addresses, foreign calls, and some ad-hoc optimisations that are+  convenient to do here and effective in common cases.  Comments in the+  code below explain these.++Pass 2:++- Calculate live registers, but taking into account that nothing is live at the+  entry to a proc point.++- At each proc point and call continuation insert reloads of live registers from+  the stack (they were saved by Pass 1).+++Note [Two pass approach]++The main reason for Pass 2 is being able to insert only the reloads that are+needed and the fact that the two passes need different liveness information.+Let's consider an example:++  .....+   \ /+    D   <- proc point+   / \+  E   F+   \ /+    G   <- proc point+    |+    X++Pass 1 needs liveness assuming that local variables are preserved across calls.+This is important because it needs to save any local registers to the stack+(e.g., if register a is used in block X, it must be saved before any native+call).+However, for Pass 2, where we want to reload registers from stack (in a proc+point), this is overly conservative and would lead us to generate reloads in D+for things used in X, even though we're going to generate reloads in G anyway+(since it's also a proc point).+So Pass 2 calculates liveness knowing that nothing is live at the entry to a+proc point. This means that in D we only need to reload things used in E or F.+This can be quite important, for an extreme example see testcase for #3294.++Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1+is a forward one. Furthermore, Pass 1 is creating code that uses local registers+(saving them before a call), which the liveness analysis for Pass 2 must see to+be correct.++-}+++-- All stack locations are expressed as positive byte offsets from the+-- "base", which is defined to be the address above the return address+-- on the stack on entry to this CmmProc.+--+-- Lower addresses have higher StackLocs.+--+type StackLoc = ByteOff++{-+ A StackMap describes the stack at any given point.  At a continuation+ it has a particular layout, like this:++         |             | <- base+         |-------------|+         |     ret0    | <- base + 8+         |-------------|+         .  upd frame  . <- base + sm_ret_off+         |-------------|+         |             |+         .    vars     .+         . (live/dead) .+         |             | <- base + sm_sp - sm_args+         |-------------|+         |    ret1     |+         .  ret vals   . <- base + sm_sp    (<--- Sp points here)+         |-------------|++Why do we include the final return address (ret0) in our stack map?  I+have absolutely no idea, but it seems to be done that way consistently+in the rest of the code generator, so I played along here. --SDM++Note that we will be constructing an info table for the continuation+(ret1), which needs to describe the stack down to, but not including,+the update frame (or ret0, if there is no update frame).+-}++data StackMap = StackMap+ {  sm_sp   :: StackLoc+       -- ^ the offset of Sp relative to the base on entry+       -- to this block.+ ,  sm_args :: ByteOff+       -- ^ the number of bytes of arguments in the area for this block+       -- Defn: the offset of young(L) relative to the base is given by+       -- (sm_sp - sm_args) of the StackMap for block L.+ ,  sm_ret_off :: ByteOff+       -- ^ Number of words of stack that we do not describe with an info+       -- table, because it contains an update frame.+ ,  sm_regs :: UniqFM (LocalReg,StackLoc)+       -- ^ regs on the stack+ }++instance Outputable StackMap where+  ppr StackMap{..} =+     text "Sp = " <> int sm_sp $$+     text "sm_args = " <> int sm_args $$+     text "sm_ret_off = " <> int sm_ret_off $$+     text "sm_regs = " <> pprUFM sm_regs ppr+++cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph+               -> UniqSM (CmmGraph, LabelMap StackMap)+cmmLayoutStack dflags procpoints entry_args+               graph@(CmmGraph { g_entry = entry })+  = do+    -- We need liveness info. Dead assignments are removed later+    -- by the sinking pass.+    let liveness = cmmLocalLiveness dflags graph+        blocks = revPostorder graph++    (final_stackmaps, _final_high_sp, new_blocks) <-+          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->+            layout dflags procpoints liveness entry entry_args+                   rec_stackmaps rec_high_sp blocks++    blocks_with_reloads <-+        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks+    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads+    return (ofBlockList entry new_blocks', final_stackmaps)++-- -----------------------------------------------------------------------------+-- Pass 1+-- -----------------------------------------------------------------------------++layout :: DynFlags+       -> LabelSet                      -- proc points+       -> LabelMap CmmLocalLive         -- liveness+       -> BlockId                       -- entry+       -> ByteOff                       -- stack args on entry++       -> LabelMap StackMap             -- [final] stack maps+       -> ByteOff                       -- [final] Sp high water mark++       -> [CmmBlock]                    -- [in] blocks++       -> UniqSM+          ( LabelMap StackMap           -- [out] stack maps+          , ByteOff                     -- [out] Sp high water mark+          , [CmmBlock]                  -- [out] new blocks+          )++layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks+  = go blocks init_stackmap entry_args []+  where+    (updfr, cont_info)  = collectContInfo blocks++    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args+                                               , sm_args = entry_args+                                               , sm_ret_off = updfr+                                               , sm_regs = emptyUFM+                                               }++    go [] acc_stackmaps acc_hwm acc_blocks+      = return (acc_stackmaps, acc_hwm, acc_blocks)++    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks+      = do+       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0++       let stack0@StackMap { sm_sp = sp0 }+               = mapFindWithDefault+                     (pprPanic "no stack map for" (ppr entry_lbl))+                     entry_lbl acc_stackmaps++       -- (a) Update the stack map to include the effects of+       --     assignments in this block+       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0++       -- (b) Look at the last node and if we are making a call or+       --     jumping to a proc point, we must save the live+       --     variables, adjust Sp, and construct the StackMaps for+       --     each of the successor blocks.  See handleLastNode for+       --     details.+       (middle1, sp_off, last1, fixup_blocks, out)+           <- handleLastNode dflags procpoints liveness cont_info+                             acc_stackmaps stack1 tscope middle0 last0++       -- (c) Manifest Sp: run over the nodes in the block and replace+       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.+       --+       -- our block:+       --    middle0          -- the original middle nodes+       --    middle1          -- live variable saves from handleLastNode+       --    Sp = Sp + sp_off -- Sp adjustment goes here+       --    last1            -- the last node+       --+       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1++       let final_blocks =+               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high+                          entry0 middle_pre sp_off last1 fixup_blocks++       let acc_stackmaps' = mapUnion acc_stackmaps out++           -- If this block jumps to the GC, then we do not take its+           -- stack usage into account for the high-water mark.+           -- Otherwise, if the only stack usage is in the stack-check+           -- failure block itself, we will do a redundant stack+           -- check.  The stack has a buffer designed to accommodate+           -- the largest amount of stack needed for calling the GC.+           --+           this_sp_hwm | isGcJump last0 = 0+                       | otherwise      = sp0 - sp_off++           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))++       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)+++-- -----------------------------------------------------------------------------++-- Not foolproof, but GCFun is the culprit we most want to catch+isGcJump :: CmmNode O C -> Bool+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })+  = l == GCFun || l == GCEnter1+isGcJump _something_else = False++-- -----------------------------------------------------------------------------++-- This doesn't seem right somehow.  We need to find out whether this+-- proc will push some update frame material at some point, so that we+-- can avoid using that area of the stack for spilling.  The+-- updfr_space field of the CmmProc *should* tell us, but it doesn't+-- (I think maybe it gets filled in later when we do proc-point+-- splitting).+--+-- So we'll just take the max of all the cml_ret_offs.  This could be+-- unnecessarily pessimistic, but probably not in the code we+-- generate.++collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)+collectContInfo blocks+  = (maximum ret_offs, mapFromList (catMaybes mb_argss))+ where+  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks++  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)+  get_cont b =+     case lastNode b of+        CmmCall { cml_cont = Just l, .. }+           -> (Just (l, cml_ret_args), cml_ret_off)+        CmmForeignCall { .. }+           -> (Just (succ, ret_args), ret_off)+        _other -> (Nothing, 0)+++-- -----------------------------------------------------------------------------+-- Updating the StackMap from middle nodes++-- Look for loads from stack slots, and update the StackMap.  This is+-- purely for optimisation reasons, so that we can avoid saving a+-- variable back to a different stack slot if it is already on the+-- stack.+--+-- This happens a lot: for example when function arguments are passed+-- on the stack and need to be immediately saved across a call, we+-- want to just leave them where they are on the stack.+--+procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap+procMiddle stackmaps node sm+  = case node of+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)+       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }+        where loc = getStackLoc area off stackmaps+     CmmAssign (CmmLocal r) _other+       -> sm { sm_regs = delFromUFM (sm_regs sm) r }+     _other+       -> sm++getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc+getStackLoc Old       n _         = n+getStackLoc (Young l) n stackmaps =+  case mapLookup l stackmaps of+    Nothing -> pprPanic "getStackLoc" (ppr l)+    Just sm -> sm_sp sm - sm_args sm + n+++-- -----------------------------------------------------------------------------+-- Handling stack allocation for a last node++-- We take a single last node and turn it into:+--+--    C1 (some statements)+--    Sp = Sp + N+--    C2 (some more statements)+--    call f()          -- the actual last node+--+-- plus possibly some more blocks (we may have to add some fixup code+-- between the last node and the continuation).+--+-- C1: is the code for saving the variables across this last node onto+-- the stack, if the continuation is a call or jumps to a proc point.+--+-- C2: if the last node is a safe foreign call, we have to inject some+-- extra code that goes *after* the Sp adjustment.++handleLastNode+   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff+   -> LabelMap StackMap -> StackMap -> CmmTickScope+   -> Block CmmNode O O+   -> CmmNode O C+   -> UniqSM+      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment+      , ByteOff            -- amount to adjust Sp+      , CmmNode O C        -- new last node+      , [CmmBlock]         -- new blocks+      , LabelMap StackMap  -- stackmaps for the continuations+      )++handleLastNode dflags procpoints liveness cont_info stackmaps+               stack0@StackMap { sm_sp = sp0 } tscp middle last+ = case last of+    --  At each return / tail call,+    --  adjust Sp to point to the last argument pushed, which+    --  is cml_args, after popping any other junk from the stack.+    CmmCall{ cml_cont = Nothing, .. } -> do+      let sp_off = sp0 - cml_args+      return ([], sp_off, last, [], mapEmpty)++    --  At each CmmCall with a continuation:+    CmmCall{ cml_cont = Just cont_lbl, .. } ->+       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off++    CmmForeignCall{ succ = cont_lbl, .. } -> do+       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off+            -- one word of args: the return address++    CmmBranch {}     ->  handleBranches+    CmmCondBranch {} ->  handleBranches+    CmmSwitch {}     ->  handleBranches++  where+     -- Calls and ForeignCalls are handled the same way:+     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff+              -> ( [CmmNode O O]+                 , ByteOff+                 , CmmNode O C+                 , [CmmBlock]+                 , LabelMap StackMap+                 )+     lastCall lbl cml_args cml_ret_args cml_ret_off+      =  ( assignments+         , spOffsetForCall sp0 cont_stack cml_args+         , last+         , [] -- no new blocks+         , mapSingleton lbl cont_stack )+      where+         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off+++     prepareStack lbl cml_ret_args cml_ret_off+       | Just cont_stack <- mapLookup lbl stackmaps+             -- If we have already seen this continuation before, then+             -- we just have to make the stack look the same:+       = (fixupStack stack0 cont_stack, cont_stack)+             -- Otherwise, we have to allocate the stack frame+       | otherwise+       = (save_assignments, new_cont_stack)+       where+        (new_cont_stack, save_assignments)+           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0+++     -- For other last nodes (branches), if any of the targets is a+     -- proc point, we have to set up the stack to match what the proc+     -- point is expecting.+     --+     handleBranches :: UniqSM ( [CmmNode O O]+                                , ByteOff+                                , CmmNode O C+                                , [CmmBlock]+                                , LabelMap StackMap )++     handleBranches+         -- Note [diamond proc point]+       | Just l <- futureContinuation middle+       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]+       = do+         let cont_args = mapFindWithDefault 0 l cont_info+             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)+             out = mapFromList [ (l', cont_stack)+                               | l' <- successors last ]+         return ( assigs+                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)+                , last+                , []+                , out)++        | otherwise = do+          pps <- mapM handleBranch (successors last)+          let lbl_map :: LabelMap Label+              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]+              fix_lbl l = mapFindWithDefault l l lbl_map+          return ( []+                 , 0+                 , mapSuccessors fix_lbl last+                 , concat [ blk | (_,_,_,blk) <- pps ]+                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )++     -- For each successor of this block+     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])+     handleBranch l+        --   (a) if the successor already has a stackmap, we need to+        --       shuffle the current stack to make it look the same.+        --       We have to insert a new block to make this happen.+        | Just stack2 <- mapLookup l stackmaps+        = do+             let assigs = fixupStack stack0 stack2+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             return (l, tmp_lbl, stack2, block)++        --   (b) if the successor is a proc point, save everything+        --       on the stack.+        | l `setMember` procpoints+        = do+             let cont_args = mapFindWithDefault 0 l cont_info+                 (stack2, assigs) =+                      setupStackFrame dflags l liveness (sm_ret_off stack0)+                                                        cont_args stack0+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             return (l, tmp_lbl, stack2, block)++        --   (c) otherwise, the current StackMap is the StackMap for+        --       the continuation.  But we must remember to remove any+        --       variables from the StackMap that are *not* live at+        --       the destination, because this StackMap might be used+        --       by fixupStack if this is a join point.+        | otherwise = return (l, l, stack1, [])+        where live = mapFindWithDefault (panic "handleBranch") l liveness+              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }+              is_live (r,_) = r `elemRegSet` live+++makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap+               -> CmmTickScope -> [CmmNode O O]+               -> UniqSM (Label, [CmmBlock])+makeFixupBlock dflags sp0 l stack tscope assigs+  | null assigs && sp0 == sm_sp stack = return (l, [])+  | otherwise = do+    tmp_lbl <- newBlockId+    let sp_off = sp0 - sm_sp stack+        block = blockJoin (CmmEntry tmp_lbl tscope)+                          ( maybeAddSpAdj dflags sp0 sp_off+                           $ blockFromList assigs )+                          (CmmBranch l)+    return (tmp_lbl, [block])+++-- Sp is currently pointing to current_sp,+-- we want it to point to+--    (sm_sp cont_stack - sm_args cont_stack + args)+-- so the difference is+--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)+spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff+spOffsetForCall current_sp cont_stack args+  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)+++-- | create a sequence of assignments to establish the new StackMap,+-- given the old StackMap.+fixupStack :: StackMap -> StackMap -> [CmmNode O O]+fixupStack old_stack new_stack = concatMap move new_locs+ where+     old_map  = sm_regs old_stack+     new_locs = stackSlotRegs new_stack++     move (r,n)+       | Just (_,m) <- lookupUFM old_map r, n == m = []+       | otherwise = [CmmStore (CmmStackSlot Old n)+                               (CmmReg (CmmLocal r))]++++setupStackFrame+             :: DynFlags+             -> BlockId                 -- label of continuation+             -> LabelMap CmmLocalLive   -- liveness+             -> ByteOff      -- updfr+             -> ByteOff      -- bytes of return values on stack+             -> StackMap     -- current StackMap+             -> (StackMap, [CmmNode O O])++setupStackFrame dflags lbl liveness updfr_off ret_args stack0+  = (cont_stack, assignments)+  where+      -- get the set of LocalRegs live in the continuation+      live = mapFindWithDefault Set.empty lbl liveness++      -- the stack from the base to updfr_off is off-limits.+      -- our new stack frame contains:+      --   * saved live variables+      --   * the return address [young(C) + 8]+      --   * the args for the call,+      --     which are replaced by the return values at the return+      --     point.++      -- everything up to updfr_off is off-limits+      -- stack1 contains updfr_off, plus everything we need to save+      (stack1, assignments) = allocate dflags updfr_off live stack0++      -- And the Sp at the continuation is:+      --   sm_sp stack1 + ret_args+      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args+                         , sm_args = ret_args+                         , sm_ret_off = updfr_off+                         }+++-- -----------------------------------------------------------------------------+-- Note [diamond proc point]+--+-- This special case looks for the pattern we get from a typical+-- tagged case expression:+--+--    Sp[young(L1)] = L1+--    if (R1 & 7) != 0 goto L1 else goto L2+--  L2:+--    call [R1] returns to L1+--  L1: live: {y}+--    x = R1+--+-- If we let the generic case handle this, we get+--+--    Sp[-16] = L1+--    if (R1 & 7) != 0 goto L1a else goto L2+--  L2:+--    Sp[-8] = y+--    Sp = Sp - 16+--    call [R1] returns to L1+--  L1a:+--    Sp[-8] = y+--    Sp = Sp - 16+--    goto L1+--  L1:+--    x = R1+--+-- The code for saving the live vars is duplicated in each branch, and+-- furthermore there is an extra jump in the fast path (assuming L1 is+-- a proc point, which it probably is if there is a heap check).+--+-- So to fix this we want to set up the stack frame before the+-- conditional jump.  How do we know when to do this, and when it is+-- safe?  The basic idea is, when we see the assignment+--+--   Sp[young(L)] = L+--+-- we know that+--   * we are definitely heading for L+--   * there can be no more reads from another stack area, because young(L)+--     overlaps with it.+--+-- We don't necessarily know that everything live at L is live now+-- (some might be assigned between here and the jump to L).  So we+-- simplify and only do the optimisation when we see+--+--   (1) a block containing an assignment of a return address L+--   (2) ending in a branch where one (and only) continuation goes to L,+--       and no other continuations go to proc points.+--+-- then we allocate the stack frame for L at the end of the block,+-- before the branch.+--+-- We could generalise (2), but that would make it a bit more+-- complicated to handle, and this currently catches the common case.++futureContinuation :: Block CmmNode O O -> Maybe BlockId+futureContinuation middle = foldBlockNodesB f middle Nothing+   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId+         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _+               = Just l+         f _ r = r++-- -----------------------------------------------------------------------------+-- Saving live registers++-- | Given a set of live registers and a StackMap, save all the registers+-- on the stack and return the new StackMap and the assignments to do+-- the saving.+--+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap+         -> (StackMap, [CmmNode O O])+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0+                                              , sm_regs = regs0 }+ =+   -- we only have to save regs that are not already in a slot+   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)+       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0+   in++   -- make a map of the stack+   let stack = reverse $ Array.elems $+               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $+                 ret_words ++ live_words+            where ret_words =+                   [ (x, Occupied)+                   | x <- [ 1 .. toWords dflags ret_off] ]+                  live_words =+                   [ (toWords dflags x, Occupied)+                   | (r,off) <- nonDetEltsUFM regs1,+                   -- See Note [Unique Determinism and code generation]+                     let w = localRegBytes dflags r,+                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]+   in++   -- Pass over the stack: find slots to save all the new live variables,+   -- choosing the oldest slots first (hence a foldr).+   let+       save slot ([], stack, n, assigs, regs) -- no more regs to save+          = ([], slot:stack, plusW dflags n 1, assigs, regs)+       save slot (to_save, stack, n, assigs, regs)+          = case slot of+               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)+               Empty+                 | Just (stack', r, to_save') <-+                       select_save to_save (slot:stack)+                 -> let assig = CmmStore (CmmStackSlot Old n')+                                         (CmmReg (CmmLocal r))+                        n' = plusW dflags n 1+                   in+                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)++                 | otherwise+                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)++       -- we should do better here: right now we'll fit the smallest first,+       -- but it would make more sense to fit the biggest first.+       select_save :: [LocalReg] -> [StackSlot]+                   -> Maybe ([StackSlot], LocalReg, [LocalReg])+       select_save regs stack = go regs []+         where go []     _no_fit = Nothing+               go (r:rs) no_fit+                 | Just rest <- dropEmpty words stack+                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)+                 | otherwise+                 = go rs (r:no_fit)+                 where words = localRegWords dflags r++       -- fill in empty slots as much as possible+       (still_to_save, save_stack, n, save_assigs, save_regs)+          = foldr save (to_save, [], 0, [], []) stack++       -- push any remaining live vars on the stack+       (push_sp, push_assigs, push_regs)+          = foldr push (n, [], []) still_to_save+          where+              push r (n, assigs, regs)+                = (n', assig : assigs, (r,(r,n')) : regs)+                where+                  n' = n + localRegBytes dflags r+                  assig = CmmStore (CmmStackSlot Old n')+                                   (CmmReg (CmmLocal r))++       trim_sp+          | not (null push_regs) = push_sp+          | otherwise+          = plusW dflags n (- length (takeWhile isEmpty save_stack))++       final_regs = regs1 `addListToUFM` push_regs+                          `addListToUFM` save_regs++   in+  -- XXX should be an assert+   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else++   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else++   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }+   , push_assigs ++ save_assigs )+++-- -----------------------------------------------------------------------------+-- Manifesting Sp++-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The+-- block looks like this:+--+--    middle_pre       -- the middle nodes+--    Sp = Sp + sp_off -- Sp adjustment goes here+--    last             -- the last node+--+-- And we have some extra blocks too (that don't contain Sp adjustments)+--+-- The adjustment for middle_pre will be different from that for+-- middle_post, because the Sp adjustment intervenes.+--+manifestSp+   :: DynFlags+   -> LabelMap StackMap  -- StackMaps for other blocks+   -> StackMap           -- StackMap for this block+   -> ByteOff            -- Sp on entry to the block+   -> ByteOff            -- SpHigh+   -> CmmNode C O        -- first node+   -> [CmmNode O O]      -- middle+   -> ByteOff            -- sp_off+   -> CmmNode O C        -- last node+   -> [CmmBlock]         -- new blocks+   -> [CmmBlock]         -- final blocks with Sp manifest++manifestSp dflags stackmaps stack0 sp0 sp_high+           first middle_pre sp_off last fixup_blocks+  = final_block : fixup_blocks'+  where+    area_off = getAreaOff stackmaps++    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)++    final_middle = maybeAddSpAdj dflags sp0 sp_off+                 . blockFromList+                 . map adj_pre_sp+                 . elimStackStores stack0 stackmaps area_off+                 $ middle_pre+    final_last    = optStackCheck (adj_post_sp last)++    final_block   = blockJoin first final_middle final_last++    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks++getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)+getAreaOff _ Old = 0+getAreaOff stackmaps (Young l) =+  case mapLookup l stackmaps of+    Just sm -> sm_sp sm - sm_args sm+    Nothing -> pprPanic "getAreaOff" (ppr l)+++maybeAddSpAdj+  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O+maybeAddSpAdj dflags sp0 sp_off block =+  add_initial_unwind $ add_adj_unwind $ adj block+  where+    adj block+      | sp_off /= 0+      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)+      | otherwise = block+    -- Add unwind pseudo-instruction at the beginning of each block to+    -- document Sp level for debugging+    add_initial_unwind block+      | debugLevel dflags > 0+      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block+      | otherwise+      = block+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)++    -- Add unwind pseudo-instruction right after the Sp adjustment+    -- if there is one.+    add_adj_unwind block+      | debugLevel dflags > 0+      , sp_off /= 0+      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]+      | otherwise+      = block+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)++{- Note [SP old/young offsets]++Sp(L) is the Sp offset on entry to block L relative to the base of the+OLD area.++SpArgs(L) is the size of the young area for L, i.e. the number of+arguments.++ - in block L, each reference to [old + N] turns into+   [Sp + Sp(L) - N]++ - in block L, each reference to [young(L') + N] turns into+   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]++ - be careful with the last node of each block: Sp has already been adjusted+   to be Sp + Sp(L) - Sp(L')+-}++areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr++areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)+  = cmmOffset dflags spExpr (sp_old - area_off area - n)+    -- Replace (CmmStackSlot area n) with an offset from Sp++areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)+  = mkIntExpr dflags sp_hwm+    -- Replace CmmHighStackMark with the number of bytes of stack used,+    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap++areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)+  | falseStackCheck args+  = zeroExpr dflags+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)+  | falseStackCheck args+  = mkIntExpr dflags 1+    -- Replace a stack-overflow test that cannot fail with a no-op+    -- See Note [Always false stack check]++areaToSp _ _ _ _ other = other++-- | Determine whether a stack check cannot fail.+falseStackCheck :: [CmmExpr] -> Bool+falseStackCheck [ CmmMachOp (MO_Sub _)+                      [ CmmRegOff (CmmGlobal Sp) x_off+                      , CmmLit (CmmInt y_lit _)]+                , CmmReg (CmmGlobal SpLim)]+  = fromIntegral x_off >= y_lit+falseStackCheck _ = False++-- Note [Always false stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We can optimise stack checks of the form+--+--   if ((Sp + x) - y < SpLim) then .. else ..+--+-- where are non-negative integer byte offsets.  Since we know that+-- SpLim <= Sp (remember the stack grows downwards), this test must+-- yield False if (x >= y), so we can rewrite the comparison to False.+-- A subsequent sinking pass will later drop the dead code.+-- Optimising this away depends on knowing that SpLim <= Sp, so it is+-- really the job of the stack layout algorithm, hence we do it now.+--+-- The control flow optimiser may negate a conditional to increase+-- the likelihood of a fallthrough if the branch is not taken.  But+-- not every conditional is inverted as the control flow optimiser+-- places some requirements on the predecessors of both branch targets.+-- So we better look for the inverted comparison too.++optStackCheck :: CmmNode O C -> CmmNode O C+optStackCheck n = -- Note [Always false stack check]+ case n of+   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false+   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true+   other -> other+++-- -----------------------------------------------------------------------------++-- | Eliminate stores of the form+--+--    Sp[area+n] = r+--+-- when we know that r is already in the same slot as Sp[area+n].  We+-- could do this in a later optimisation pass, but that would involve+-- a separate analysis and we already have the information to hand+-- here.  It helps clean up some extra stack stores in common cases.+--+-- Note that we may have to modify the StackMap as we walk through the+-- code using procMiddle, since an assignment to a variable in the+-- StackMap will invalidate its mapping there.+--+elimStackStores :: StackMap+                -> LabelMap StackMap+                -> (Area -> ByteOff)+                -> [CmmNode O O]+                -> [CmmNode O O]+elimStackStores stackmap stackmaps area_off nodes+  = go stackmap nodes+  where+    go _stackmap [] = []+    go stackmap (n:ns)+     = case n of+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))+            | Just (_,off) <- lookupUFM (sm_regs stackmap) r+            , area_off area + m == off+            -> go stackmap ns+         _otherwise+            -> n : go (procMiddle stackmaps n stackmap) ns+++-- -----------------------------------------------------------------------------+-- Update info tables to include stack liveness+++setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g+  where+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =+       info_tbl { cit_rep = StackRep (get_liveness lbl) }+    fix_info _ other = other++    get_liveness :: BlockId -> Liveness+    get_liveness lbl+      = case mapLookup lbl stackmaps of+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)+          Just sm -> stackMapToLiveness dflags sm++setInfoTableStackMap _ _ d = d+++stackMapToLiveness :: DynFlags -> StackMap -> Liveness+stackMapToLiveness dflags StackMap{..} =+   reverse $ Array.elems $+        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,+                                     toWords dflags (sm_sp - sm_args)) live_words+   where+     live_words =  [ (toWords dflags off, False)+                   | (r,off) <- nonDetEltsUFM sm_regs+                   , isGcPtrType (localRegType r) ]+                   -- See Note [Unique Determinism and code generation]++-- -----------------------------------------------------------------------------+-- Pass 2+-- -----------------------------------------------------------------------------++insertReloadsAsNeeded+    :: DynFlags+    -> ProcPointSet+    -> LabelMap StackMap+    -> BlockId+    -> [CmmBlock]+    -> UniqSM [CmmBlock]+insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do+    toBlockList . fst <$>+        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty+  where+    rewriteCC :: RewriteFun CmmLocalLive+    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do+        let entry_label = entryLabel e_node+            stackmap = case mapLookup entry_label final_stackmaps of+                Just sm -> sm+                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"++            -- Merge the liveness from successor blocks and analyse the last+            -- node.+            joined = gen_kill dflags x_node $!+                         joinOutFacts liveLattice x_node fact_base0+            -- What is live at the start of middle0.+            live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined++            -- If this is a procpoint we need to add the reloads, but only if+            -- they're actually live. Furthermore, nothing is live at the entry+            -- to a proc point.+            (middle1, live_with_reloads)+                | entry_label `setMember` procpoints+                = let reloads = insertReloads dflags stackmap live_at_middle0+                  in (foldr blockCons middle0 reloads, emptyRegSet)+                | otherwise+                = (middle0, live_at_middle0)++            -- Final liveness for this block.+            !fact_base2 = mapSingleton entry_label live_with_reloads++        return (BlockCC e_node middle1 x_node, fact_base2)++insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]+insertReloads dflags stackmap live =+     [ CmmAssign (CmmLocal reg)+                 -- This cmmOffset basically corresponds to manifesting+                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]+                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))+                          (localRegType reg))+     | (reg, reg_off) <- stackSlotRegs stackmap+     , reg `elemRegSet` live+     ]+   where+     sp_off = sm_sp stackmap++-- -----------------------------------------------------------------------------+-- Lowering safe foreign calls++{-+Note [Lower safe foreign calls]++We start with++   Sp[young(L1)] = L1+ ,-----------------------+ | r1 = foo(x,y,z) returns to L1+ '-----------------------+ L1:+   R1 = r1 -- copyIn, inserted by mkSafeCall+   ...++the stack layout algorithm will arrange to save and reload everything+live across the call.  Our job now is to expand the call so we get++   Sp[young(L1)] = L1+ ,-----------------------+ | SAVE_THREAD_STATE()+ | token = suspendThread(BaseReg, interruptible)+ | r = foo(x,y,z)+ | BaseReg = resumeThread(token)+ | LOAD_THREAD_STATE()+ | R1 = r  -- copyOut+ | jump Sp[0]+ '-----------------------+ L1:+   r = R1 -- copyIn, inserted by mkSafeCall+   ...++Note the copyOut, which saves the results in the places that L1 is+expecting them (see Note [safe foreign call convention]). Note also+that safe foreign call is replace by an unsafe one in the Cmm graph.+-}++lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall dflags block+  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block+  = do+    -- Both 'id' and 'new_base' are KindNonPtr because they're+    -- RTS-only objects and are not subject to garbage collection+    id <- newTemp (bWord dflags)+    new_base <- newTemp (cmmRegType dflags baseReg)+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    save_state_code <- saveThreadState dflags+    load_state_code <- loadThreadState dflags+    let suspend = save_state_code  <*>+                  caller_save <*>+                  mkMiddle (callSuspendThread dflags id intrbl)+        midCall = mkUnsafeCall tgt res args+        resume  = mkMiddle (callResumeThread new_base id) <*>+                  -- Assign the result to BaseReg: we+                  -- might now have a different Capability!+                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>+                  caller_load <*>+                  load_state_code++        (_, regs, copyout) =+             copyOutOflow dflags NativeReturn Jump (Young succ)+                            (map (CmmReg . CmmLocal) res)+                            ret_off []++        -- NB. after resumeThread returns, the top-of-stack probably contains+        -- the stack frame for succ, but it might not: if the current thread+        -- received an exception during the call, then the stack might be+        -- different.  Hence we continue by jumping to the top stack frame,+        -- not by jumping to succ.+        jump = CmmCall { cml_target    = entryCode dflags $+                                         CmmLoad spExpr (bWord dflags)+                       , cml_cont      = Just succ+                       , cml_args_regs = regs+                       , cml_args      = widthInBytes (wordWidth dflags)+                       , cml_ret_args  = ret_args+                       , cml_ret_off   = ret_off }++    graph' <- lgraphOfAGraph ( suspend <*>+                               midCall <*>+                               resume  <*>+                               copyout <*>+                               mkLast jump, tscp)++    case toBlockList graph' of+      [one] -> let (_, middle', last) = blockSplit one+               in return (blockJoin entry (middle `blockAppend` middle') last)+      _ -> panic "lowerSafeForeignCall0"++  -- Block doesn't end in a safe foreign call:+  | otherwise = return block+++foreignLbl :: FastString -> CmmExpr+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))++callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O+callSuspendThread dflags id intrbl =+  CmmUnsafeForeignCall+       (ForeignTarget (foreignLbl (fsLit "suspendThread"))+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))+       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]++callResumeThread :: LocalReg -> LocalReg -> CmmNode O O+callResumeThread new_base id =+  CmmUnsafeForeignCall+       (ForeignTarget (foreignLbl (fsLit "resumeThread"))+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))+       [new_base] [CmmReg (CmmLocal id)]++-- -----------------------------------------------------------------------------++plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff+plusW dflags b w = b + w * wORD_SIZE dflags++data StackSlot = Occupied | Empty+     -- Occupied: a return address or part of an update frame++instance Outputable StackSlot where+  ppr Occupied = text "XXX"+  ppr Empty    = text "---"++dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]+dropEmpty 0 ss           = Just ss+dropEmpty n (Empty : ss) = dropEmpty (n-1) ss+dropEmpty _ _            = Nothing++isEmpty :: StackSlot -> Bool+isEmpty Empty = True+isEmpty _ = False++localRegBytes :: DynFlags -> LocalReg -> ByteOff+localRegBytes dflags r+    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))++localRegWords :: DynFlags -> LocalReg -> WordOff+localRegWords dflags = toWords dflags . localRegBytes dflags++toWords :: DynFlags -> ByteOff -> WordOff+toWords dflags x = x `quot` wORD_SIZE dflags+++stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]+stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)+  -- See Note [Unique Determinism and code generation]
+ compiler/GHC/Cmm/Lexer.x view
@@ -0,0 +1,368 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2004-2006+--+-- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there+-- are a few minor differences:+--+--   * extra keywords for our macros, and float32/float64 types+--   * global registers (Sp,Hp, etc.)+--+-----------------------------------------------------------------------------++{+module GHC.Cmm.Lexer (+   CmmToken(..), cmmlex,+  ) where++import GhcPrelude++import GHC.Cmm.Expr++import Lexer+import GHC.Cmm.Monad+import SrcLoc+import UniqFM+import StringBuffer+import FastString+import Ctype+import Util+--import TRACE++import Data.Word+import Data.Char+}++$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space+$white_no_nl = $whitechar # \n++$ascdigit  = 0-9+$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.+$digit     = [$ascdigit $unidigit]+$octit     = 0-7+$hexit     = [$digit A-F a-f]++$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]+$large     = [$asclarge $unilarge]++$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]+$small     = [$ascsmall $unismall \_]++$namebegin = [$large $small \. \$ \@]+$namechar  = [$namebegin $digit]++@decimal     = $digit++@octal       = $octit++@hexadecimal = $hexit++@exponent    = [eE] [\-\+]? @decimal++@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent++@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})+@strchar     = ($printable # [\"\\]) | @escape++cmm :-++$white_no_nl+           ;+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output++^\# (line)?             { begin line_prag }++-- single-line line pragmas, of the form+--    # <line> "<file>" <extra-stuff> \n+<line_prag> $digit+                     { setLine line_prag1 }+<line_prag1> \" [^\"]* \"       { setFile line_prag2 }+<line_prag2> .*                         { pop }++<0> {+  \n                    ;++  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }++  ".."                  { kw CmmT_DotDot }+  "::"                  { kw CmmT_DoubleColon }+  ">>"                  { kw CmmT_Shr }+  "<<"                  { kw CmmT_Shl }+  ">="                  { kw CmmT_Ge }+  "<="                  { kw CmmT_Le }+  "=="                  { kw CmmT_Eq }+  "!="                  { kw CmmT_Ne }+  "&&"                  { kw CmmT_BoolAnd }+  "||"                  { kw CmmT_BoolOr }++  "True"                { kw CmmT_True  }+  "False"               { kw CmmT_False }+  "likely"              { kw CmmT_likely}++  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }+  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }+  F@decimal             { global_regN FloatReg }+  D@decimal             { global_regN DoubleReg }+  L@decimal             { global_regN LongReg }+  Sp                    { global_reg Sp }+  SpLim                 { global_reg SpLim }+  Hp                    { global_reg Hp }+  HpLim                 { global_reg HpLim }+  CCCS                  { global_reg CCCS }+  CurrentTSO            { global_reg CurrentTSO }+  CurrentNursery        { global_reg CurrentNursery }+  HpAlloc               { global_reg HpAlloc }+  BaseReg               { global_reg BaseReg }+  MachSp                { global_reg MachSp }+  UnwindReturnReg       { global_reg UnwindReturnReg }++  $namebegin $namechar* { name }++  0 @octal              { tok_octal }+  @decimal              { tok_decimal }+  0[xX] @hexadecimal    { tok_hexadecimal }+  @floating_point       { strtoken tok_float }++  \" @strchar* \"       { strtoken tok_string }+}++{+data CmmToken+  = CmmT_SpecChar  Char+  | CmmT_DotDot+  | CmmT_DoubleColon+  | CmmT_Shr+  | CmmT_Shl+  | CmmT_Ge+  | CmmT_Le+  | CmmT_Eq+  | CmmT_Ne+  | CmmT_BoolAnd+  | CmmT_BoolOr+  | CmmT_CLOSURE+  | CmmT_INFO_TABLE+  | CmmT_INFO_TABLE_RET+  | CmmT_INFO_TABLE_FUN+  | CmmT_INFO_TABLE_CONSTR+  | CmmT_INFO_TABLE_SELECTOR+  | CmmT_else+  | CmmT_export+  | CmmT_section+  | CmmT_goto+  | CmmT_if+  | CmmT_call+  | CmmT_jump+  | CmmT_foreign+  | CmmT_never+  | CmmT_prim+  | CmmT_reserve+  | CmmT_return+  | CmmT_returns+  | CmmT_import+  | CmmT_switch+  | CmmT_case+  | CmmT_default+  | CmmT_push+  | CmmT_unwind+  | CmmT_bits8+  | CmmT_bits16+  | CmmT_bits32+  | CmmT_bits64+  | CmmT_bits128+  | CmmT_bits256+  | CmmT_bits512+  | CmmT_float32+  | CmmT_float64+  | CmmT_gcptr+  | CmmT_GlobalReg GlobalReg+  | CmmT_Name      FastString+  | CmmT_String    String+  | CmmT_Int       Integer+  | CmmT_Float     Rational+  | CmmT_EOF+  | CmmT_False+  | CmmT_True+  | CmmT_likely+  deriving (Show)++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)++begin :: Int -> Action+begin code _span _str _len = do liftP (pushLexState code); lexToken++pop :: Action+pop _span _buf _len = liftP popLexState >> lexToken++special_char :: Action+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))++kw :: CmmToken -> Action+kw tok span _buf _len = return (L span tok)++global_regN :: (Int -> GlobalReg) -> Action+global_regN con span buf len+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))+  where buf' = stepOn buf+        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit++global_reg :: GlobalReg -> Action+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))++strtoken :: (String -> CmmToken) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++name :: Action+name span buf len =+  case lookupUFM reservedWordsFM fs of+        Just tok -> return (L span tok)+        Nothing  -> return (L span (CmmT_Name fs))+  where+        fs = lexemeToFastString buf len++reservedWordsFM = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "CLOSURE",            CmmT_CLOSURE ),+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),+        ( "else",               CmmT_else ),+        ( "export",             CmmT_export ),+        ( "section",            CmmT_section ),+        ( "goto",               CmmT_goto ),+        ( "if",                 CmmT_if ),+        ( "call",               CmmT_call ),+        ( "jump",               CmmT_jump ),+        ( "foreign",            CmmT_foreign ),+        ( "never",              CmmT_never ),+        ( "prim",               CmmT_prim ),+        ( "reserve",            CmmT_reserve ),+        ( "return",             CmmT_return ),+        ( "returns",            CmmT_returns ),+        ( "import",             CmmT_import ),+        ( "switch",             CmmT_switch ),+        ( "case",               CmmT_case ),+        ( "default",            CmmT_default ),+        ( "push",               CmmT_push ),+        ( "unwind",             CmmT_unwind ),+        ( "bits8",              CmmT_bits8 ),+        ( "bits16",             CmmT_bits16 ),+        ( "bits32",             CmmT_bits32 ),+        ( "bits64",             CmmT_bits64 ),+        ( "bits128",            CmmT_bits128 ),+        ( "bits256",            CmmT_bits256 ),+        ( "bits512",            CmmT_bits512 ),+        ( "float32",            CmmT_float32 ),+        ( "float64",            CmmT_float64 ),+-- New forms+        ( "b8",                 CmmT_bits8 ),+        ( "b16",                CmmT_bits16 ),+        ( "b32",                CmmT_bits32 ),+        ( "b64",                CmmT_bits64 ),+        ( "b128",               CmmT_bits128 ),+        ( "b256",               CmmT_bits256 ),+        ( "b512",               CmmT_bits512 ),+        ( "f32",                CmmT_float32 ),+        ( "f64",                CmmT_float64 ),+        ( "gcptr",              CmmT_gcptr ),+        ( "likely",             CmmT_likely),+        ( "True",               CmmT_True  ),+        ( "False",              CmmT_False )+        ]++tok_decimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))++tok_octal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))++tok_hexadecimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))++tok_float str = CmmT_Float $! readRational str++tok_string str = CmmT_String (read str)+                 -- urk, not quite right, but it'll do for now++-- -----------------------------------------------------------------------------+-- Line pragmas++setLine :: Int -> Action+setLine code span buf len = do+  let line = parseUnsignedInteger buf len 10 octDecDigit+  liftP $ do+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)+          -- subtract one: the line number refers to the *following* line+    -- trace ("setLine "  ++ show line) $ do+    popLexState >> pushLexState code+  lexToken++setFile :: Int -> Action+setFile code span buf len = do+  let file = lexemeToFastString (stepOn buf) (len-2)+  liftP $ do+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))+    popLexState >> pushLexState code+  lexToken++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++cmmlex :: (Located CmmToken -> PD a) -> PD a+cmmlex cont = do+  (L span tok) <- lexToken+  --trace ("token: " ++ show tok) $ do+  cont (L (RealSrcSpan span) tok)++lexToken :: PD (RealLocated CmmToken)+lexToken = do+  inp@(loc1,buf) <- getInput+  sc <- liftP getLexState+  case alexScan inp sc of+    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1+                  liftP (setLastToken span 0)+                  return (L span CmmT_EOF)+    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(end,_buf2) len t -> do+        setInput inp2+        let span = mkRealSrcSpan loc1 end+        span `seq` liftP (setLastToken span len)+        t span buf len++-- -----------------------------------------------------------------------------+-- Monad stuff++-- Stuff that Alex needs to know about our input type:+type AlexInput = (RealSrcLoc,StringBuffer)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (_,s) = prevChar s '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = chr $ fromIntegral b++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (loc,s)+  | atEnd s   = Nothing+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))+  where c    = currentChar s+        b    = fromIntegral $ ord $ c+        loc' = advanceSrcLoc loc c+        s'   = stepOn s++getInput :: PD AlexInput+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)++setInput :: AlexInput -> PD ()+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()+}
+ compiler/GHC/Cmm/Lint.hs view
@@ -0,0 +1,261 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2011+--+-- CmmLint: checking the correctness of Cmm statements and expressions+--+-----------------------------------------------------------------------------+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+module GHC.Cmm.Lint (+    cmmLint, cmmLintGraph+  ) where++import GhcPrelude++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Liveness+import GHC.Cmm.Switch (switchTargetsToList)+import GHC.Cmm.Ppr () -- For Outputable instances+import Outputable+import DynFlags++import Control.Monad (ap)++-- Things to check:+--     - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)+--     - check for branches to blocks that don't exist+--     - check types++-- -----------------------------------------------------------------------------+-- Exported entry points:++cmmLint :: (Outputable d, Outputable h)+        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops++cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g++runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc+runCmmLint dflags l p =+   case unCL (l p) dflags of+     Left err -> Just (vcat [text "Cmm lint error:",+                             nest 2 err,+                             text "Program was:",+                             nest 2 (ppr p)])+     Right _  -> Nothing++lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()+lintCmmDecl dflags (CmmProc _ lbl _ g)+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g+lintCmmDecl _ (CmmData {})+  = return ()+++lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()+lintCmmGraph dflags g =+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks+    -- cmmLiveness throws an error if there are registers+    -- live on entry to the graph (i.e. undefined+    -- variables)+  where+       blocks = toBlockList g+       labels = setFromList (map entryLabel blocks)+++lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()+lintCmmBlock labels block+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do+        let (_, middle, last) = blockSplit block+        mapM_ lintCmmMiddle (blockToList middle)+        lintCmmLast labels last++-- -----------------------------------------------------------------------------+-- lintCmmExpr++-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking+-- byte/word mismatches.++lintCmmExpr :: CmmExpr -> CmmLint CmmType+lintCmmExpr (CmmLoad expr rep) = do+  _ <- lintCmmExpr expr+  -- Disabled, if we have the inlining phase before the lint phase,+  -- we can have funny offsets due to pointer tagging. -- EZY+  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $+  --   cmmCheckWordAddress expr+  return rep+lintCmmExpr expr@(CmmMachOp op args) = do+  dflags <- getDynFlags+  tys <- mapM lintCmmExpr args+  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op+        then cmmCheckMachOp op args tys+        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)+lintCmmExpr (CmmRegOff reg offset)+  = do dflags <- getDynFlags+       let rep = typeWidth (cmmRegType dflags reg)+       lintCmmExpr (CmmMachOp (MO_Add rep)+                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])+lintCmmExpr expr =+  do dflags <- getDynFlags+     return (cmmExprType dflags expr)++-- Check for some common byte/word mismatches (eg. Sp + 1)+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys+  = cmmCheckMachOp op [reg, lit] tys+cmmCheckMachOp op _ tys+  = do dflags <- getDynFlags+       return (machOpResultType dflags op tys)++{-+isOffsetOp :: MachOp -> Bool+isOffsetOp (MO_Add _) = True+isOffsetOp (MO_Sub _) = True+isOffsetOp _ = False++-- This expression should be an address from which a word can be loaded:+-- check for funny-looking sub-word offsets.+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  = cmmLintDubiousWordOffset e+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  = cmmLintDubiousWordOffset e+_cmmCheckWordAddress _+  = return ()++-- No warnings for unaligned arithmetic with the node register,+-- which is used to extract fields from tagged constructor closures.+notNodeReg :: CmmExpr -> Bool+notNodeReg (CmmReg reg) | reg == nodeReg = False+notNodeReg _                             = True+-}++lintCmmMiddle :: CmmNode O O -> CmmLint ()+lintCmmMiddle node = case node of+  CmmComment _ -> return ()+  CmmTick _    -> return ()+  CmmUnwind{}  -> return ()++  CmmAssign reg expr -> do+            dflags <- getDynFlags+            erep <- lintCmmExpr expr+            let reg_ty = cmmRegType dflags reg+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)+                then return ()+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty++  CmmStore l r -> do+            _ <- lintCmmExpr l+            _ <- lintCmmExpr r+            return ()++  CmmUnsafeForeignCall target _formals actuals -> do+            lintTarget target+            mapM_ lintCmmExpr actuals+++lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()+lintCmmLast labels node = case node of+  CmmBranch id -> checkTarget id++  CmmCondBranch e t f _ -> do+            dflags <- getDynFlags+            mapM_ checkTarget [t,f]+            _ <- lintCmmExpr e+            checkCond dflags e++  CmmSwitch e ids -> do+            dflags <- getDynFlags+            mapM_ checkTarget $ switchTargetsToList ids+            erep <- lintCmmExpr e+            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)+              then return ()+              else cmmLintErr (text "switch scrutinee is not a word: " <>+                               ppr e <> text " :: " <> ppr erep)++  CmmCall { cml_target = target, cml_cont = cont } -> do+          _ <- lintCmmExpr target+          maybe (return ()) checkTarget cont++  CmmForeignCall tgt _ args succ _ _ _ -> do+          lintTarget tgt+          mapM_ lintCmmExpr args+          checkTarget succ+ where+  checkTarget id+     | setMember id labels = return ()+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)+++lintTarget :: ForeignTarget -> CmmLint ()+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()+lintTarget (PrimTarget {})     = return ()+++checkCond :: DynFlags -> CmmExpr -> CmmLint ()+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values+checkCond _ expr+    = cmmLintErr (hang (text "expression is not a conditional:") 2+                         (ppr expr))++-- -----------------------------------------------------------------------------+-- CmmLint monad++-- just a basic error monad:++newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }+    deriving (Functor)++instance Applicative CmmLint where+      pure a = CmmLint (\_ -> Right a)+      (<*>) = ap++instance Monad CmmLint where+  CmmLint m >>= k = CmmLint $ \dflags ->+                                case m dflags of+                                Left e -> Left e+                                Right a -> unCL (k a) dflags++instance HasDynFlags CmmLint where+    getDynFlags = CmmLint (\dflags -> Right dflags)++cmmLintErr :: SDoc -> CmmLint a+cmmLintErr msg = CmmLint (\_ -> Left msg)++addLintInfo :: SDoc -> CmmLint a -> CmmLint a+addLintInfo info thing = CmmLint $ \dflags ->+   case unCL thing dflags of+        Left err -> Left (hang info 2 err)+        Right a  -> Right a++cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a+cmmLintMachOpErr expr argsRep opExpectsRep+     = cmmLintErr (text "in MachOp application: " $$+                   nest 2 (ppr  expr) $$+                      (text "op is expecting: " <+> ppr opExpectsRep) $$+                      (text "arguments provide: " <+> ppr argsRep))++cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a+cmmLintAssignErr stmt e_ty r_ty+  = cmmLintErr (text "in assignment: " $$+                nest 2 (vcat [ppr stmt,+                              text "Reg ty:" <+> ppr r_ty,+                              text "Rhs ty:" <+> ppr e_ty]))+++{-+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a+cmmLintDubiousWordOffset expr+   = cmmLintErr (text "offset is not a multiple of words: " $$+                 nest 2 (ppr expr))+-}+
+ compiler/GHC/Cmm/Liveness.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.Cmm.Liveness+    ( CmmLocalLive+    , cmmLocalLiveness+    , cmmGlobalLiveness+    , liveLattice+    , gen_kill+    )+where++import GhcPrelude++import DynFlags+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Ppr.Expr () -- For Outputable instances+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Label++import Maybes+import Outputable++-----------------------------------------------------------------------------+-- Calculating what variables are live on entry to a basic block+-----------------------------------------------------------------------------++-- | The variables live on entry to a block+type CmmLive r = RegSet r+type CmmLocalLive = CmmLive LocalReg++-- | The dataflow lattice+liveLattice :: Ord r => DataflowLattice (CmmLive r)+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}+liveLattice = DataflowLattice emptyRegSet add+  where+    add (OldFact old) (NewFact new) =+        let !join = plusRegSet old new+        in changedIf (sizeRegSet join > sizeRegSet old) join++-- | A mapping from block labels to the variables live on entry+type BlockEntryLiveness r = LabelMap (CmmLive r)++-----------------------------------------------------------------------------+-- | Calculated liveness info for a CmmGraph+-----------------------------------------------------------------------------++cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg+cmmLocalLiveness dflags graph =+    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty+  where+    entry = g_entry graph+    check facts =+        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts++cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg+cmmGlobalLiveness dflags graph =+    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty++-- | On entry to the procedure, there had better not be any LocalReg's live-in.+noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a+noLiveOnEntry bid in_fact x =+  if nullRegSet in_fact then x+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)++gen_kill+    :: (DefinerOfRegs r n, UserOfRegs r n)+    => DynFlags -> n -> CmmLive r -> CmmLive r+gen_kill dflags node set =+    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node+    in foldRegsUsed dflags extendRegSet afterKill node+{-# INLINE gen_kill #-}++xferLive+    :: forall r.+       ( UserOfRegs r (CmmNode O O)+       , DefinerOfRegs r (CmmNode O O)+       , UserOfRegs r (CmmNode O C)+       , DefinerOfRegs r (CmmNode O C)+       )+    => DynFlags -> TransferFun (CmmLive r)+xferLive dflags (BlockCC eNode middle xNode) fBase =+    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase+        !result = foldNodesBwdOO (gen_kill dflags) middle joined+    in mapSingleton (entryLabel eNode) result+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
+ compiler/GHC/Cmm/Monad.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- A Parser monad with access to the 'DynFlags'.+--+-- The 'P' monad  only has access to the subset of of 'DynFlags'+-- required for parsing Haskell.++-- The parser for C-- requires access to a lot more of the 'DynFlags',+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.+-----------------------------------------------------------------------------+module GHC.Cmm.Monad (+    PD(..)+  , liftP+  ) where++import GhcPrelude++import Control.Monad+import qualified Control.Monad.Fail as MonadFail++import DynFlags+import Lexer++newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }++instance Functor PD where+  fmap = liftM++instance Applicative PD where+  pure = returnPD+  (<*>) = ap++instance Monad PD where+  (>>=) = thenPD+#if !MIN_VERSION_base(4,13,0)+  fail = MonadFail.fail+#endif++instance MonadFail.MonadFail PD where+  fail = failPD++liftP :: P a -> PD a+liftP (P f) = PD $ \_ s -> f s++returnPD :: a -> PD a+returnPD = liftP . return++thenPD :: PD a -> (a -> PD b) -> PD b+(PD m) `thenPD` k = PD $ \d s ->+        case m d s of+                POk s1 a         -> unPD (k a) d s1+                PFailed s1 -> PFailed s1++failPD :: String -> PD a+failPD = liftP . fail++instance HasDynFlags PD where+   getDynFlags = PD $ \d s -> POk s d
+ compiler/GHC/Cmm/Opt.hs view
@@ -0,0 +1,423 @@+-----------------------------------------------------------------------------+--+-- Cmm optimisation+--+-- (c) The University of Glasgow 2006+--+-----------------------------------------------------------------------------++module GHC.Cmm.Opt (+        constantFoldNode,+        constantFoldExpr,+        cmmMachOpFold,+        cmmMachOpFoldM+ ) where++import GhcPrelude++import GHC.Cmm.Utils+import GHC.Cmm+import DynFlags+import Util++import Outputable+import GHC.Platform++import Data.Bits+import Data.Maybe+++constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x+constantFoldNode dflags = mapExp (constantFoldExpr dflags)++constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr+constantFoldExpr dflags = wrapRecExp f+  where f (CmmMachOp op args) = cmmMachOpFold dflags op args+        f (CmmRegOff r 0) = CmmReg r+        f e = e++-- -----------------------------------------------------------------------------+-- MachOp constant folder++-- Now, try to constant-fold the MachOps.  The arguments have already+-- been optimized and folded.++cmmMachOpFold+    :: DynFlags+    -> MachOp       -- The operation from an CmmMachOp+    -> [CmmExpr]    -- The optimized arguments+    -> CmmExpr++cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)++-- Returns Nothing if no changes, useful for Hoopl, also reduces+-- allocation!+cmmMachOpFoldM+    :: DynFlags+    -> MachOp+    -> [CmmExpr]+    -> Maybe CmmExpr++cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]+  = Just $ case op of+      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)+      MO_Not _   -> CmmLit (CmmInt (complement x) rep)++        -- these are interesting: we must first narrow to the+        -- "from" type, in order to truncate to the correct size.+        -- The final narrow/widen to the destination type+        -- is implicit in the CmmLit.+      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)+      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)+      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)++      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op+++-- Eliminate conversion NOPs+cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x+cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x++-- Eliminate nested conversions where possible+cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]+  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,+    Just (_,   rep3,signed2) <- isIntConversion conv_outer+  = case () of+        -- widen then narrow to the same size is a nop+      _ | rep1 < rep2 && rep1 == rep3 -> Just x+        -- Widen then narrow to different size: collapse to single conversion+        -- but remember to use the signedness from the widening, just in case+        -- the final conversion is a widen.+        | rep1 < rep2 && rep2 > rep3 ->+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+        -- Nested widenings: collapse if the signedness is the same+        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+        -- Nested narrowings: collapse+        | rep1 > rep2 && rep2 > rep3 ->+            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]+        | otherwise ->+            Nothing+  where+        isIntConversion (MO_UU_Conv rep1 rep2)+          = Just (rep1,rep2,False)+        isIntConversion (MO_SS_Conv rep1 rep2)+          = Just (rep1,rep2,True)+        isIntConversion _ = Nothing++        intconv True  = MO_SS_Conv+        intconv False = MO_UU_Conv++-- ToDo: a narrow of a load can be collapsed into a narrow load, right?+-- but what if the architecture only supports word-sized loads, should+-- we do the transformation anyway?++cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]+  = case mop of+        -- for comparisons: don't forget to narrow the arguments before+        -- comparing, since they might be out of range.+        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))+        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))++        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))+        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))+        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))+        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))++        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))+        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))+        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))+        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))++        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)+        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)+        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)+        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)+        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)+        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)+        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)++        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)+        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)+        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)++        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)+        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)++        _          -> Nothing++   where+        x_u = narrowU xrep x+        y_u = narrowU xrep y+        x_s = narrowS xrep x+        y_s = narrowS xrep y+++-- When possible, shift the constants to the right-hand side, so that we+-- can match for strength reductions.  Note that the code generator will+-- also assume that constants have been shifted to the right when+-- possible.++cmmMachOpFoldM dflags op [x@(CmmLit _), y]+   | not (isLit y) && isCommutableMachOp op+   = Just (cmmMachOpFold dflags op [y, x])++-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are+-- moved to the right, it is more likely that we will find+-- opportunities for constant folding when the expression is+-- right-associated.+--+-- ToDo: this appears to introduce a quadratic behaviour due to the+-- nested cmmMachOpFold.  Can we fix this?+--+-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2+-- is also a lit (otherwise arg1 would be on the right).  If we+-- put arg1 on the left of the rearranged expression, we'll get into a+-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...+--+-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the+-- PicBaseReg from the corresponding label (or label difference).+--+cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]+   | mop2 `associates_with` mop1+     && not (isLit arg1) && not (isPicReg arg1)+   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])+   where+     MO_Add{} `associates_with` MO_Sub{} = True+     mop1 `associates_with` mop2 =+        mop1 == mop2 && isAssociativeMachOp mop1++-- special case: (a - b) + c  ==>  a + (c - b)+cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]+   | not (isLit arg1) && not (isPicReg arg1)+   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])++-- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)+--+-- this is better because lit+N is a single link-time constant (e.g. a+-- CmmLabelOff), so the right-hand expression needs only one+-- instruction, whereas the left needs two.  This happens when pointer+-- tagging gives us label+offset, and PIC turns the label into+-- PicBaseReg + label.+--+cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]+                          , CmmLit (CmmInt n rep) ]+  | isPicReg pic+  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]+  where off = fromIntegral (narrowS rep n)++-- Make a RegOff if we can+cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))++-- Fold label(+/-)offset into a CmmLit where possible++cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))+++-- Comparison of literal with widened operand: perform the comparison+-- at the smaller width, as long as the literal is within range.++-- We can't do the reverse trick, when the operand is narrowed:+-- narrowing throws away bits from the operand, there's no way to do+-- the same comparison at the larger size.++cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]+  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try+    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],+        -- if the operand is widened:+    Just (rep, signed, narrow_fn) <- maybe_conversion conv,+        -- and this is a comparison operation:+    Just narrow_cmp <- maybe_comparison cmp rep signed,+        -- and the literal fits in the smaller size:+    i == narrow_fn rep i+        -- then we can do the comparison at the smaller size+  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])+ where+    maybe_conversion (MO_UU_Conv from to)+        | to > from+        = Just (from, False, narrowU)+    maybe_conversion (MO_SS_Conv from to)+        | to > from+        = Just (from, True, narrowS)++        -- don't attempt to apply this optimisation when the source+        -- is a float; see #1916+    maybe_conversion _ = Nothing++        -- careful (#2080): if the original comparison was signed, but+        -- we were doing an unsigned widen, then we must do an+        -- unsigned comparison at the smaller size.+    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)+    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)+    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)+    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)+    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)+    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)+    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)+    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)+    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)+    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)+    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)+    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)+    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)+    maybe_comparison _ _ _ = Nothing++-- We can often do something with constants of 0 and 1 ...+-- See Note [Comparison operators]++cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]+  = case mop of+        -- Arithmetic+        MO_Add   _ -> Just x   -- x + 0 = x+        MO_Sub   _ -> Just x   -- x - 0 = x+        MO_Mul   _ -> Just y   -- x * 0 = 0++        -- Logical operations+        MO_And   _ -> Just y   -- x &     0 = 0+        MO_Or    _ -> Just x   -- x |     0 = x+        MO_Xor   _ -> Just x   -- x `xor` 0 = x++        -- Shifts+        MO_Shl   _ -> Just x   -- x << 0 = x+        MO_S_Shr _ -> Just x   -- ditto shift-right+        MO_U_Shr _ -> Just x++        -- Comparisons; these ones are trickier+        -- See Note [Comparison operators]+        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y+        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y+        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y+        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto+        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0+        MO_S_Lt  _ | isComparisonExpr x -> Just zero+        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1+        MO_S_Ge  _ | isComparisonExpr x -> Just one++        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y+        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        _ -> Nothing+  where+    zero = CmmLit (CmmInt 0 (wordWidth dflags))+    one  = CmmLit (CmmInt 1 (wordWidth dflags))++cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]+  = case mop of+        -- Arithmetic: x*1 = x, etc+        MO_Mul    _ -> Just x+        MO_S_Quot _ -> Just x+        MO_U_Quot _ -> Just x+        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)+        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)++        -- Comparisons; trickier+        -- See Note [Comparison operators]+        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y+        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y+        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y+        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto+        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0+        MO_S_Gt  _ | isComparisonExpr x -> Just zero+        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1+        MO_S_Le  _ | isComparisonExpr x -> Just one+        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y+        MO_S_Ge  _ | isComparisonExpr x -> Just x+        _ -> Nothing+  where+    zero = CmmLit (CmmInt 0 (wordWidth dflags))+    one  = CmmLit (CmmInt 1 (wordWidth dflags))++-- Now look for multiplication/division by powers of 2 (integers).++cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]+  = case mop of+        MO_Mul rep+           | Just p <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])+        MO_U_Quot rep+           | Just p <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])+        MO_U_Rem rep+           | Just _ <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])+        MO_S_Quot rep+           | Just p <- exactLog2 n,+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require+                                -- it is a reg.  FIXME: remove this restriction.+                Just (cmmMachOpFold dflags (MO_S_Shr rep)+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])+        MO_S_Rem rep+           | Just p <- exactLog2 n,+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require+                                -- it is a reg.  FIXME: remove this restriction.+                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).+                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)+                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.+                Just (cmmMachOpFold dflags (MO_Sub rep)+                    [x, cmmMachOpFold dflags (MO_And rep)+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])+        _ -> Nothing+  where+    -- In contrast with unsigned integers, for signed ones+    -- shift right is not the same as quot, because it rounds+    -- to minus infinity, whereas quot rounds toward zero.+    -- To fix this up, we add one less than the divisor to the+    -- dividend if it is a negative number.+    --+    -- to avoid a test/jump, we use the following sequence:+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)+    --      x2 = y & (divisor-1)+    --      result = x + x2+    -- this could be done a bit more simply using conditional moves,+    -- but we're processor independent here.+    --+    -- we optimise the divide by 2 case slightly, generating+    --      x1 = x >> word_size-1  (unsigned)+    --      return = x + x1+    signedQuotRemHelper :: Width -> Integer -> CmmExpr+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]+      where+        bits = fromIntegral (widthInBits rep) - 1+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]+        x2 = if p == 1 then x1 else+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]++-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x+-- Unfortunately this needs a unique supply because x might not be a+-- register.  See #2253 (program 6) for an example.+++-- Anything else is just too hard.++cmmMachOpFoldM _ _ _ = Nothing++{- Note [Comparison operators]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   CmmCondBranch ((x>#y) == 1) t f+we really want to convert to+   CmmCondBranch (x>#y) t f++That's what the constant-folding operations on comparison operators do above.+-}+++-- -----------------------------------------------------------------------------+-- Utils++isPicReg :: CmmExpr -> Bool+isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True+isPicReg _ = False
+ compiler/GHC/Cmm/Parser.y view
@@ -0,0 +1,1442 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2004-2012+--+-- Parser for concrete Cmm.+--+-----------------------------------------------------------------------------++{- -----------------------------------------------------------------------------+Note [Syntax of .cmm files]++NOTE: You are very much on your own in .cmm.  There is very little+error checking at all:++  * Type errors are detected by the (optional) -dcmm-lint pass, if you+    don't turn this on then a type error will likely result in a panic+    from the native code generator.++  * Passing the wrong number of arguments or arguments of the wrong+    type is not detected.++There are two ways to write .cmm code:++ (1) High-level Cmm code delegates the stack handling to GHC, and+     never explicitly mentions Sp or registers.++ (2) Low-level Cmm manages the stack itself, and must know about+     calling conventions.++Whether you want high-level or low-level Cmm is indicated by the+presence of an argument list on a procedure.  For example:++foo ( gcptr a, bits32 b )+{+  // this is high-level cmm code++  if (b > 0) {+     // we can make tail calls passing arguments:+     jump stg_ap_0_fast(a);+  }++  push (stg_upd_frame_info, a) {+    // stack frames can be explicitly pushed++    (x,y) = call wibble(a,b,3,4);+      // calls pass arguments and return results using the native+      // Haskell calling convention.  The code generator will automatically+      // construct a stack frame and an info table for the continuation.++    return (x,y);+      // we can return multiple values from the current proc+  }+}++bar+{+  // this is low-level cmm code, indicated by the fact that we did not+  // put an argument list on bar.++  x = R1;  // the calling convention is explicit: better be careful+           // that this works on all platforms!++  jump %ENTRY_CODE(Sp(0))+}++Here is a list of rules for high-level and low-level code.  If you+break the rules, you get a panic (for using a high-level construct in+a low-level proc), or wrong code (when using low-level code in a+high-level proc).  This stuff isn't checked! (TODO!)++High-level only:++  - tail-calls with arguments, e.g.+    jump stg_fun (arg1, arg2);++  - function calls:+    (ret1,ret2) = call stg_fun (arg1, arg2);++    This makes a call with the NativeNodeCall convention, and the+    values are returned to the following code using the NativeReturn+    convention.++  - returning:+    return (ret1, ret2)++    These use the NativeReturn convention to return zero or more+    results to the caller.++  - pushing stack frames:+    push (info_ptr, field1, ..., fieldN) { ... statements ... }++  - reserving temporary stack space:++      reserve N = x { ... }++    this reserves an area of size N (words) on the top of the stack,+    and binds its address to x (a local register).  Typically this is+    used for allocating temporary storage for passing to foreign+    functions.++    Note that if you make any native calls or invoke the GC in the+    scope of the reserve block, you are responsible for ensuring that+    the stack you reserved is laid out correctly with an info table.++Low-level only:++  - References to Sp, R1-R8, F1-F4 etc.++    NB. foreign calls may clobber the argument registers R1-R8, F1-F4+    etc., so ensure they are saved into variables around foreign+    calls.++  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp+    directly.++Both high-level and low-level code can use a raw tail-call:++    jump stg_fun [R1,R2]++NB. you *must* specify the list of GlobalRegs that are passed via a+jump, otherwise the register allocator will assume that all the+GlobalRegs are dead at the jump.+++Calling Conventions+-------------------++High-level procedures use the NativeNode calling convention, or the+NativeReturn convention if the 'return' keyword is used (see Stack+Frames below).++Low-level procedures implement their own calling convention, so it can+be anything at all.++If a low-level procedure implements the NativeNode calling convention,+then it can be called by high-level code using an ordinary function+call.  In general this is hard to arrange because the calling+convention depends on the number of physical registers available for+parameter passing, but there are two cases where the calling+convention is platform-independent:++ - Zero arguments.++ - One argument of pointer or non-pointer word type; this is always+   passed in R1 according to the NativeNode convention.++ - Returning a single value; these conventions are fixed and platform+   independent.+++Stack Frames+------------++A stack frame is written like this:++INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )+               return ( arg1, ..., argM )+{+  ... code ...+}++where field1 ... fieldN are the fields of the stack frame (with types)+arg1...argN are the values returned to the stack frame (with types).+The return values are assumed to be passed according to the+NativeReturn convention.++On entry to the code, the stack frame looks like:++   |----------|+   | fieldN   |+   |   ...    |+   | field1   |+   |----------|+   | info_ptr |+   |----------|+   |  argN    |+   |   ...    | <- Sp++and some of the args may be in registers.++We prepend the code by a copyIn of the args, and assign all the stack+frame fields to their formals.  The initial "arg offset" for stack+layout purposes consists of the whole stack frame plus any args that+might be on the stack.++A tail-call may pass a stack frame to the callee using the following+syntax:++jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)++where info_ptr and field1..fieldN describe the stack frame, and+arg1..argN are the arguments passed to f using the NativeNodeCall+convention. Note if a field is longer than a word (e.g. a D_ on+a 32-bit machine) then the call will push as many words as+necessary to the stack to accommodate it (e.g. 2).+++----------------------------------------------------------------------------- -}++{+{-# LANGUAGE TupleSections #-}++module GHC.Cmm.Parser ( parseCmmFile ) where++import GhcPrelude++import GHC.StgToCmm.ExtCode+import GHC.Cmm.CallConv+import GHC.StgToCmm.Prof+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit+                               , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff+                               , getUpdFrameOff )+import qualified GHC.StgToCmm.Monad as F+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Expr+import GHC.StgToCmm.Closure+import GHC.StgToCmm.Layout     hiding (ArgRep(..))+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )+import CoreSyn            ( Tickish(SourceNote) )++import GHC.Cmm.Opt+import GHC.Cmm.Graph+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch     ( mkSwitchTargets )+import GHC.Cmm.Info+import GHC.Cmm.BlockId+import GHC.Cmm.Lexer+import GHC.Cmm.CLabel+import GHC.Cmm.Monad+import GHC.Runtime.Layout+import Lexer++import CostCentre+import ForeignCall+import Module+import GHC.Platform+import Literal+import Unique+import UniqFM+import SrcLoc+import DynFlags+import ErrUtils+import StringBuffer+import FastString+import Panic+import Constants+import Outputable+import BasicTypes+import Bag              ( emptyBag, unitBag )+import Var++import Control.Monad+import Data.Array+import Data.Char        ( ord )+import System.Exit+import Data.Maybe+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as BS8++#include "HsVersions.h"+}++%expect 0++%token+        ':'     { L _ (CmmT_SpecChar ':') }+        ';'     { L _ (CmmT_SpecChar ';') }+        '{'     { L _ (CmmT_SpecChar '{') }+        '}'     { L _ (CmmT_SpecChar '}') }+        '['     { L _ (CmmT_SpecChar '[') }+        ']'     { L _ (CmmT_SpecChar ']') }+        '('     { L _ (CmmT_SpecChar '(') }+        ')'     { L _ (CmmT_SpecChar ')') }+        '='     { L _ (CmmT_SpecChar '=') }+        '`'     { L _ (CmmT_SpecChar '`') }+        '~'     { L _ (CmmT_SpecChar '~') }+        '/'     { L _ (CmmT_SpecChar '/') }+        '*'     { L _ (CmmT_SpecChar '*') }+        '%'     { L _ (CmmT_SpecChar '%') }+        '-'     { L _ (CmmT_SpecChar '-') }+        '+'     { L _ (CmmT_SpecChar '+') }+        '&'     { L _ (CmmT_SpecChar '&') }+        '^'     { L _ (CmmT_SpecChar '^') }+        '|'     { L _ (CmmT_SpecChar '|') }+        '>'     { L _ (CmmT_SpecChar '>') }+        '<'     { L _ (CmmT_SpecChar '<') }+        ','     { L _ (CmmT_SpecChar ',') }+        '!'     { L _ (CmmT_SpecChar '!') }++        '..'    { L _ (CmmT_DotDot) }+        '::'    { L _ (CmmT_DoubleColon) }+        '>>'    { L _ (CmmT_Shr) }+        '<<'    { L _ (CmmT_Shl) }+        '>='    { L _ (CmmT_Ge) }+        '<='    { L _ (CmmT_Le) }+        '=='    { L _ (CmmT_Eq) }+        '!='    { L _ (CmmT_Ne) }+        '&&'    { L _ (CmmT_BoolAnd) }+        '||'    { L _ (CmmT_BoolOr) }++        'True'  { L _ (CmmT_True ) }+        'False' { L _ (CmmT_False) }+        'likely'{ L _ (CmmT_likely)}++        'CLOSURE'       { L _ (CmmT_CLOSURE) }+        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }+        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }+        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }+        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }+        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }+        'else'          { L _ (CmmT_else) }+        'export'        { L _ (CmmT_export) }+        'section'       { L _ (CmmT_section) }+        'goto'          { L _ (CmmT_goto) }+        'if'            { L _ (CmmT_if) }+        'call'          { L _ (CmmT_call) }+        'jump'          { L _ (CmmT_jump) }+        'foreign'       { L _ (CmmT_foreign) }+        'never'         { L _ (CmmT_never) }+        'prim'          { L _ (CmmT_prim) }+        'reserve'       { L _ (CmmT_reserve) }+        'return'        { L _ (CmmT_return) }+        'returns'       { L _ (CmmT_returns) }+        'import'        { L _ (CmmT_import) }+        'switch'        { L _ (CmmT_switch) }+        'case'          { L _ (CmmT_case) }+        'default'       { L _ (CmmT_default) }+        'push'          { L _ (CmmT_push) }+        'unwind'        { L _ (CmmT_unwind) }+        'bits8'         { L _ (CmmT_bits8) }+        'bits16'        { L _ (CmmT_bits16) }+        'bits32'        { L _ (CmmT_bits32) }+        'bits64'        { L _ (CmmT_bits64) }+        'bits128'       { L _ (CmmT_bits128) }+        'bits256'       { L _ (CmmT_bits256) }+        'bits512'       { L _ (CmmT_bits512) }+        'float32'       { L _ (CmmT_float32) }+        'float64'       { L _ (CmmT_float64) }+        'gcptr'         { L _ (CmmT_gcptr) }++        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }+        NAME            { L _ (CmmT_Name        $$) }+        STRING          { L _ (CmmT_String      $$) }+        INT             { L _ (CmmT_Int         $$) }+        FLOAT           { L _ (CmmT_Float       $$) }++%monad { PD } { >>= } { return }+%lexer { cmmlex } { L _ CmmT_EOF }+%name cmmParse cmm+%tokentype { Located CmmToken }++-- C-- operator precedences, taken from the C-- spec+%right '||'     -- non-std extension, called %disjoin in C--+%right '&&'     -- non-std extension, called %conjoin in C--+%right '!'+%nonassoc '>=' '>' '<=' '<' '!=' '=='+%left '|'+%left '^'+%left '&'+%left '>>' '<<'+%left '-' '+'+%left '/' '*' '%'+%right '~'++%%++cmm     :: { CmmParse () }+        : {- empty -}                   { return () }+        | cmmtop cmm                    { do $1; $2 }++cmmtop  :: { CmmParse () }+        : cmmproc                       { $1 }+        | cmmdata                       { $1 }+        | decl                          { $1 }+        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'+                {% liftP . withThisPackage $ \pkg ->+                   do lits <- sequence $6;+                      staticClosure pkg $3 $5 (map getLit lits) }++-- The only static closures in the RTS are dummy closures like+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need+-- to provide the full generality of static closures here.+-- In particular:+--      * CCS can always be CCS_DONT_CARE+--      * closure is always extern+--      * payload is always empty+--      * we can derive closure and info table labels from a single NAME++cmmdata :: { CmmParse () }+        : 'section' STRING '{' data_label statics '}'+                { do lbl <- $4;+                     ss <- sequence $5;+                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }++data_label :: { CmmParse CLabel }+    : NAME ':'+                {% liftP . withThisPackage $ \pkg ->+                   return (mkCmmDataLabel pkg $1) }++statics :: { [CmmParse [CmmStatic]] }+        : {- empty -}                   { [] }+        | static statics                { $1 : $2 }++static  :: { CmmParse [CmmStatic] }+        : type expr ';' { do e <- $2;+                             return [CmmStaticLit (getLit e)] }+        | type ';'                      { return [CmmUninitialised+                                                        (widthInBytes (typeWidth $1))] }+        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised+                                                        (fromIntegral $3)] }+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised+                                                (widthInBytes (typeWidth $1) *+                                                        fromIntegral $3)] }+        | 'CLOSURE' '(' NAME lits ')'+                { do { lits <- sequence $4+                ; dflags <- getDynFlags+                     ; return $ map CmmStaticLit $+                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)+                         -- mkForeignLabel because these are only used+                         -- for CHARLIKE and INTLIKE closures in the RTS.+                        dontCareCCS (map getLit lits) [] [] [] } }+        -- arrays of closures required for the CHARLIKE & INTLIKE arrays++lits    :: { [CmmParse CmmExpr] }+        : {- empty -}           { [] }+        | ',' expr lits         { $2 : $3 }++cmmproc :: { CmmParse () }+        : info maybe_conv maybe_formals maybe_body+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-+                       getCodeScoped $ loopDecls $ do {+                         (entry_ret_label, info, stk_formals) <- $1;+                         dflags <- getDynFlags;+                         formals <- sequence (fromMaybe [] $3);+                         withName (showSDoc dflags (ppr entry_ret_label))+                           $4;+                         return (entry_ret_label, info, stk_formals, formals) }+                     let do_layout = isJust $3+                     code (emitProcWithStackFrame $2 info+                                entry_ret_label stk_formals formals agraph+                                do_layout ) }++maybe_conv :: { Convention }+           : {- empty -}        { NativeNodeCall }+           | 'return'           { NativeReturn }++maybe_body :: { CmmParse () }+           : ';'                { return () }+           | '{' body '}'       { withSourceNote $1 $3 $2 }++info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }+        : NAME+                {% liftP . withThisPackage $ \pkg ->+                   do   newFunctionName $1 pkg+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }+++        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'+                -- ptrs, nptrs, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $11 $13+                          rep  = mkRTSRep (fromIntegral $9) $+                                   mkHeapRep dflags False (fromIntegral $5)+                                                   (fromIntegral $7) Thunk+                              -- not really Thunk, but that makes the info table+                              -- we want.+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }++        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'+                -- ptrs, nptrs, closure type, description, type, fun type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $11 $13+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))+                                -- Arity zero, arg_type $15+                          rep = mkRTSRep (fromIntegral $9) $+                                    mkHeapRep dflags False (fromIntegral $5)+                                                    (fromIntegral $7) ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }+                -- we leave most of the fields zero here.  This is only used+                -- to generate the BCO info table in the RTS at the moment.++        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'+                -- ptrs, nptrs, tag, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $13 $15+                          ty  = Constr (fromIntegral $9)  -- Tag+                                       (BS8.pack $13)+                          rep = mkRTSRep (fromIntegral $11) $+                                  mkHeapRep dflags False (fromIntegral $5)+                                                  (fromIntegral $7) ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },+                              []) }++                     -- If profiling is on, this string gets duplicated,+                     -- but that's the way the old code did it we can fix it some other time.++        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'+                -- selector, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $9 $11+                          ty  = ThunkSelector (fromIntegral $5)+                          rep = mkRTSRep (fromIntegral $7) $+                                   mkHeapRep dflags False 0 0 ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }++        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'+                -- closure type (no live regs)+                {% liftP . withThisPackage $ \pkg ->+                   do let prof = NoProfilingInfo+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []+                      return (mkCmmRetLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }++        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'+                -- closure type, live regs+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      live <- sequence $7+                      let prof = NoProfilingInfo+                          -- drop one for the info pointer+                          bitmap = mkLiveness dflags (drop 1 live)+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap+                      return (mkCmmRetLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              live) }++body    :: { CmmParse () }+        : {- empty -}                   { return () }+        | decl body                     { do $1; $2 }+        | stmt body                     { do $1; $2 }++decl    :: { CmmParse () }+        : type names ';'                { mapM_ (newLocal $1) $2 }+        | 'import' importNames ';'      { mapM_ newImport $2 }+        | 'export' names ';'            { return () }  -- ignore exports+++-- an imported function name, with optional packageId+importNames+        :: { [(FastString, CLabel)] }+        : importName                    { [$1] }+        | importName ',' importNames    { $1 : $3 }++importName+        :: { (FastString,  CLabel) }++        -- A label imported without an explicit packageId.+        --      These are taken to come from some foreign, unnamed package.+        : NAME+        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }++        -- as previous 'NAME', but 'IsData'+        | 'CLOSURE' NAME+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }++        -- A label imported with an explicit packageId.+        | STRING NAME+        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }+++names   :: { [FastString] }+        : NAME                          { [$1] }+        | NAME ',' names                { $1 : $3 }++stmt    :: { CmmParse () }+        : ';'                                   { return () }++        | NAME ':'+                { do l <- newLabel $1; emitLabel l }++++        | lreg '=' expr ';'+                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }+        | type '[' expr ']' '=' expr ';'+                { withSourceNote $2 $7 (doStore $1 $3 $6) }++        -- Gah! We really want to say "foreign_results" but that causes+        -- a shift/reduce conflict with assignment.  We either+        -- we expand out the no-result and single result cases or+        -- we tweak the syntax to avoid the conflict.  The later+        -- option is taken here because the other way would require+        -- multiple levels of expanding and get unwieldy.+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'+                {% foreignCall $3 $1 $4 $6 $8 $9 }+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'+                {% primCall $1 $4 $6 }+        -- stmt-level macros, stealing syntax from ordinary C-- function calls.+        -- Perhaps we ought to use the %%-form?+        | NAME '(' exprs0 ')' ';'+                {% stmtMacro $1 $3  }+        | 'switch' maybe_range expr '{' arms default '}'+                { do as <- sequence $5; doSwitch $2 $3 as $6 }+        | 'goto' NAME ';'+                { do l <- lookupLabel $2; emit (mkBranch l) }+        | 'return' '(' exprs0 ')' ';'+                { doReturn $3 }+        | 'jump' expr vols ';'+                { doRawJump $2 $3 }+        | 'jump' expr '(' exprs0 ')' ';'+                { doJumpWithStack $2 [] $4 }+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'+                { doJumpWithStack $2 $4 $7 }+        | 'call' expr '(' exprs0 ')' ';'+                { doCall $2 [] $4 }+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'+                { doCall $6 $2 $8 }+        | 'if' bool_expr cond_likely 'goto' NAME+                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }+        | 'if' bool_expr cond_likely '{' body '}' else+                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }+        | 'push' '(' exprs0 ')' maybe_body+                { pushStackFrame $3 $5 }+        | 'reserve' expr '=' lreg maybe_body+                { reserveStackFrame $2 $4 $5 }+        | 'unwind' unwind_regs ';'+                { $2 >>= code . emitUnwind }++unwind_regs+        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }+        : GLOBALREG '=' expr_or_unknown ',' unwind_regs+                { do e <- $3; rest <- $5; return (($1, e) : rest) }+        | GLOBALREG '=' expr_or_unknown+                { do e <- $3; return [($1, e)] }++-- | Used by unwind to indicate unknown unwinding values.+expr_or_unknown+        :: { CmmParse (Maybe CmmExpr) }+        : 'return'+                { do return Nothing }+        | expr+                { do e <- $1; return (Just e) }++foreignLabel     :: { CmmParse CmmExpr }+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }++opt_never_returns :: { CmmReturnInfo }+        :                               { CmmMayReturn }+        | 'never' 'returns'             { CmmNeverReturns }++bool_expr :: { CmmParse BoolExpr }+        : bool_op                       { $1 }+        | expr                          { do e <- $1; return (BoolTest e) }++bool_op :: { CmmParse BoolExpr }+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;+                                          return (BoolAnd e1 e2) }+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;+                                          return (BoolOr e1 e2)  }+        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }+        | '(' bool_op ')'               { $2 }++safety  :: { Safety }+        : {- empty -}                   { PlayRisky }+        | STRING                        {% parseSafety $1 }++vols    :: { [GlobalReg] }+        : '[' ']'                       { [] }+        | '[' '*' ']'                   {% do df <- getDynFlags+                                         ; return (realArgRegsCover df) }+                                           -- All of them. See comment attached+                                           -- to realArgRegsCover+        | '[' globals ']'               { $2 }++globals :: { [GlobalReg] }+        : GLOBALREG                     { [$1] }+        | GLOBALREG ',' globals         { $1 : $3 }++maybe_range :: { Maybe (Integer,Integer) }+        : '[' INT '..' INT ']'  { Just ($2, $4) }+        | {- empty -}           { Nothing }++arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }+        : {- empty -}                   { [] }+        | arm arms                      { $1 : $2 }++arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }+        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }++arm_body :: { CmmParse (Either BlockId (CmmParse ())) }+        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }+        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }++ints    :: { [Integer] }+        : INT                           { [ $1 ] }+        | INT ',' ints                  { $1 : $3 }++default :: { Maybe (CmmParse ()) }+        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }+        -- taking a few liberties with the C-- syntax here; C-- doesn't have+        -- 'default' branches+        | {- empty -}                   { Nothing }++-- Note: OldCmm doesn't support a first class 'else' statement, though+-- CmmNode does.+else    :: { CmmParse () }+        : {- empty -}                   { return () }+        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }++cond_likely :: { Maybe Bool }+        : '(' 'likely' ':' 'True'  ')'  { Just True  }+        | '(' 'likely' ':' 'False' ')'  { Just False }+        | {- empty -}                   { Nothing }+++-- we have to write this out longhand so that Happy's precedence rules+-- can kick in.+expr    :: { CmmParse CmmExpr }+        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }+        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }+        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }+        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }+        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }+        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }+        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }+        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }+        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }+        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }+        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }+        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }+        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }+        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }+        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }+        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }+        | '~' expr                      { mkMachOp MO_Not [$2] }+        | '-' expr                      { mkMachOp MO_S_Neg [$2] }+        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;+                                                return (mkMachOp mo [$1,$5]) } }+        | expr0                         { $1 }++expr0   :: { CmmParse CmmExpr }+        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }+        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }+        | STRING                 { do s <- code (newStringCLit $1);+                                      return (CmmLit s) }+        | reg                    { $1 }+        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }+        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }+        | '(' expr ')'           { $2 }+++-- leaving out the type of a literal gives you the native word size in C--+maybe_ty :: { CmmType }+        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }+        | '::' type                     { $2 }++cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }+        : {- empty -}                   { [] }+        | cmm_hint_exprs                { $1 }++cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }+        : cmm_hint_expr                 { [$1] }+        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }++cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }+        : expr                          { do e <- $1;+                                             return (e, inferCmmHint e) }+        | expr STRING                   {% do h <- parseCmmHint $2;+                                              return $ do+                                                e <- $1; return (e, h) }++exprs0  :: { [CmmParse CmmExpr] }+        : {- empty -}                   { [] }+        | exprs                         { $1 }++exprs   :: { [CmmParse CmmExpr] }+        : expr                          { [ $1 ] }+        | expr ',' exprs                { $1 : $3 }++reg     :: { CmmParse CmmExpr }+        : NAME                  { lookupName $1 }+        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }++foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }+        : {- empty -}                   { [] }+        | '(' foreign_formals ')' '='   { $2 }++foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }+        : foreign_formal                        { [$1] }+        | foreign_formal ','                    { [$1] }+        | foreign_formal ',' foreign_formals    { $1 : $3 }++foreign_formal :: { CmmParse (LocalReg, ForeignHint) }+        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }+        | STRING local_lreg     {% do h <- parseCmmHint $1;+                                      return $ do+                                         e <- $2; return (e,h) }++local_lreg :: { CmmParse LocalReg }+        : NAME                  { do e <- lookupName $1;+                                     return $+                                       case e of+                                        CmmReg (CmmLocal r) -> r+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }++lreg    :: { CmmParse CmmReg }+        : NAME                  { do e <- lookupName $1;+                                     return $+                                       case e of+                                        CmmReg r -> r+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }+        | GLOBALREG             { return (CmmGlobal $1) }++maybe_formals :: { Maybe [CmmParse LocalReg] }+        : {- empty -}           { Nothing }+        | '(' formals0 ')'      { Just $2 }++formals0 :: { [CmmParse LocalReg] }+        : {- empty -}           { [] }+        | formals               { $1 }++formals :: { [CmmParse LocalReg] }+        : formal ','            { [$1] }+        | formal                { [$1] }+        | formal ',' formals       { $1 : $3 }++formal :: { CmmParse LocalReg }+        : type NAME             { newLocal $1 $2 }++type    :: { CmmType }+        : 'bits8'               { b8 }+        | typenot8              { $1 }++typenot8 :: { CmmType }+        : 'bits16'              { b16 }+        | 'bits32'              { b32 }+        | 'bits64'              { b64 }+        | 'bits128'             { b128 }+        | 'bits256'             { b256 }+        | 'bits512'             { b512 }+        | 'float32'             { f32 }+        | 'float64'             { f64 }+        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }++{+section :: String -> SectionType+section "text"      = Text+section "data"      = Data+section "rodata"    = ReadOnlyData+section "relrodata" = RelocatableReadOnlyData+section "bss"       = UninitialisedData+section s           = OtherSection s++mkString :: String -> CmmStatic+mkString s = CmmString (BS8.pack s)++-- |+-- Given an info table, decide what the entry convention for the proc+-- is.  That is, for an INFO_TABLE_RET we want the return convention,+-- otherwise it is a NativeNodeCall.+--+infoConv :: Maybe CmmInfoTable -> Convention+infoConv Nothing = NativeNodeCall+infoConv (Just info)+  | isStackRep (cit_rep info) = NativeReturn+  | otherwise                 = NativeNodeCall++-- mkMachOp infers the type of the MachOp from the type of its first+-- argument.  We assume that this is correct: for MachOps that don't have+-- symmetrical args (e.g. shift ops), the first arg determines the type of+-- the op.+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr+mkMachOp fn args = do+  dflags <- getDynFlags+  arg_exprs <- sequence args+  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)++getLit :: CmmExpr -> CmmLit+getLit (CmmLit l) = l+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r+getLit _ = panic "invalid literal" -- TODO messy failure++nameToMachOp :: FastString -> PD (Width -> MachOp)+nameToMachOp name =+  case lookupUFM machOps name of+        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Just m  -> return m++exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)+exprOp name args_code = do+  dflags <- getDynFlags+  case lookupUFM (exprMacros dflags) name of+     Just f  -> return $ do+        args <- sequence args_code+        return (f args)+     Nothing -> do+        mo <- nameToMachOp name+        return $ mkMachOp mo args_code++exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)+exprMacros dflags = listToUFM [+  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),+  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )+  ]++-- we understand a subset of C-- primitives:+machOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "add",        MO_Add ),+        ( "sub",        MO_Sub ),+        ( "eq",         MO_Eq ),+        ( "ne",         MO_Ne ),+        ( "mul",        MO_Mul ),+        ( "neg",        MO_S_Neg ),+        ( "quot",       MO_S_Quot ),+        ( "rem",        MO_S_Rem ),+        ( "divu",       MO_U_Quot ),+        ( "modu",       MO_U_Rem ),++        ( "ge",         MO_S_Ge ),+        ( "le",         MO_S_Le ),+        ( "gt",         MO_S_Gt ),+        ( "lt",         MO_S_Lt ),++        ( "geu",        MO_U_Ge ),+        ( "leu",        MO_U_Le ),+        ( "gtu",        MO_U_Gt ),+        ( "ltu",        MO_U_Lt ),++        ( "and",        MO_And ),+        ( "or",         MO_Or ),+        ( "xor",        MO_Xor ),+        ( "com",        MO_Not ),+        ( "shl",        MO_Shl ),+        ( "shrl",       MO_U_Shr ),+        ( "shra",       MO_S_Shr ),++        ( "fadd",       MO_F_Add ),+        ( "fsub",       MO_F_Sub ),+        ( "fneg",       MO_F_Neg ),+        ( "fmul",       MO_F_Mul ),+        ( "fquot",      MO_F_Quot ),++        ( "feq",        MO_F_Eq ),+        ( "fne",        MO_F_Ne ),+        ( "fge",        MO_F_Ge ),+        ( "fle",        MO_F_Le ),+        ( "fgt",        MO_F_Gt ),+        ( "flt",        MO_F_Lt ),++        ( "lobits8",  flip MO_UU_Conv W8  ),+        ( "lobits16", flip MO_UU_Conv W16 ),+        ( "lobits32", flip MO_UU_Conv W32 ),+        ( "lobits64", flip MO_UU_Conv W64 ),++        ( "zx16",     flip MO_UU_Conv W16 ),+        ( "zx32",     flip MO_UU_Conv W32 ),+        ( "zx64",     flip MO_UU_Conv W64 ),++        ( "sx16",     flip MO_SS_Conv W16 ),+        ( "sx32",     flip MO_SS_Conv W32 ),+        ( "sx64",     flip MO_SS_Conv W64 ),++        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode+        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode+        ( "f2i8",     flip MO_FS_Conv W8 ),+        ( "f2i16",    flip MO_FS_Conv W16 ),+        ( "f2i32",    flip MO_FS_Conv W32 ),+        ( "f2i64",    flip MO_FS_Conv W64 ),+        ( "i2f32",    flip MO_SF_Conv W32 ),+        ( "i2f64",    flip MO_SF_Conv W64 )+        ]++callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))+callishMachOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "read_barrier", (MO_ReadBarrier,)),+        ( "write_barrier", (MO_WriteBarrier,)),+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),+        ( "memset", memcpyLikeTweakArgs MO_Memset ),+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),+        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),++        ("prefetch0", (MO_Prefetch_Data 0,)),+        ("prefetch1", (MO_Prefetch_Data 1,)),+        ("prefetch2", (MO_Prefetch_Data 2,)),+        ("prefetch3", (MO_Prefetch_Data 3,)),++        ( "popcnt8",  (MO_PopCnt W8,)),+        ( "popcnt16", (MO_PopCnt W16,)),+        ( "popcnt32", (MO_PopCnt W32,)),+        ( "popcnt64", (MO_PopCnt W64,)),++        ( "pdep8",  (MO_Pdep W8,)),+        ( "pdep16", (MO_Pdep W16,)),+        ( "pdep32", (MO_Pdep W32,)),+        ( "pdep64", (MO_Pdep W64,)),++        ( "pext8",  (MO_Pext W8,)),+        ( "pext16", (MO_Pext W16,)),+        ( "pext32", (MO_Pext W32,)),+        ( "pext64", (MO_Pext W64,)),++        ( "cmpxchg8",  (MO_Cmpxchg W8,)),+        ( "cmpxchg16", (MO_Cmpxchg W16,)),+        ( "cmpxchg32", (MO_Cmpxchg W32,)),+        ( "cmpxchg64", (MO_Cmpxchg W64,))++        -- ToDo: the rest, maybe+        -- edit: which rest?+        -- also: how do we tell CMM Lint how to type check callish macops?+    ]+  where+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"+    memcpyLikeTweakArgs op args@(_:_) =+        (op align, args')+      where+        args' = init args+        align = case last args of+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger+          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)+        -- The alignment of memcpy-ish operations must be a+        -- compile-time constant. We verify this here, passing it around+        -- in the MO_* constructor. In order to do this, however, we+        -- must intercept the arguments in primCall.++parseSafety :: String -> PD Safety+parseSafety "safe"   = return PlaySafe+parseSafety "unsafe" = return PlayRisky+parseSafety "interruptible" = return PlayInterruptible+parseSafety str      = fail ("unrecognised safety: " ++ str)++parseCmmHint :: String -> PD ForeignHint+parseCmmHint "ptr"    = return AddrHint+parseCmmHint "signed" = return SignedHint+parseCmmHint str      = fail ("unrecognised hint: " ++ str)++-- labels are always pointers, so we might as well infer the hint+inferCmmHint :: CmmExpr -> ForeignHint+inferCmmHint (CmmLit (CmmLabel _)) = AddrHint+inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint+inferCmmHint _ = NoHint++isPtrGlobalReg Sp                    = True+isPtrGlobalReg SpLim                 = True+isPtrGlobalReg Hp                    = True+isPtrGlobalReg HpLim                 = True+isPtrGlobalReg CCCS                  = True+isPtrGlobalReg CurrentTSO            = True+isPtrGlobalReg CurrentNursery        = True+isPtrGlobalReg (VanillaReg _ VGcPtr) = True+isPtrGlobalReg _                     = False++happyError :: PD a+happyError = PD $ \_ s -> unP srcParseFail s++-- -----------------------------------------------------------------------------+-- Statement-level macros++stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())+stmtMacro fun args_code = do+  case lookupUFM stmtMacros fun of+    Nothing -> fail ("unknown macro: " ++ unpackFS fun)+    Just fcode -> return $ do+        args <- sequence args_code+        code (fcode args)++stmtMacros :: UniqFM ([CmmExpr] -> FCode ())+stmtMacros = listToUFM [+  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),++  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),+  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),++  -- completely generic heap and stack checks, for use in high-level cmm.+  ( fsLit "HP_CHK_GEN",            \[bytes] ->+                                      heapStackCheckGen Nothing (Just bytes) ),+  ( fsLit "STK_CHK_GEN",           \[] ->+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),++  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but+  -- we use the stack for a bit of temporary storage in a couple of primops+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->+                                      heapStackCheckGen (Just bytes) Nothing ),++  -- A stack check on entry to a thunk, where the argument is the thunk pointer.+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),++  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),++  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),++  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),+  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->+                                        emitSetDynHdr ptr info ccs ),+  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->+                                        tickyAllocPrim hdr goods slop ),+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->+                                        tickyAllocPAP goods slop ),+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->+                                        tickyAllocThunk goods slop ),+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )+ ]++emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()+emitPushUpdateFrame sp e = do+  dflags <- getDynFlags+  emitUpdateFrame dflags sp mkUpdInfoLabel e++pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()+pushStackFrame fields body = do+  dflags <- getDynFlags+  exprs <- sequence fields+  updfr_off <- getUpdFrameOff+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old+                                           [] updfr_off exprs+  emit g+  withUpdFrameOff new_updfr_off body++reserveStackFrame+  :: CmmParse CmmExpr+  -> CmmParse CmmReg+  -> CmmParse ()+  -> CmmParse ()+reserveStackFrame psize preg body = do+  dflags <- getDynFlags+  old_updfr_off <- getUpdFrameOff+  reg <- preg+  esize <- psize+  let size = case constantFoldExpr dflags esize of+               CmmLit (CmmInt n _) -> n+               _other -> pprPanic "CmmParse: not a compile-time integer: "+                            (ppr esize)+  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size+  emitAssign reg (CmmStackSlot Old frame)+  withUpdFrameOff frame body++profilingInfo dflags desc_str ty_str+  = if not (gopt Opt_SccProfilingOn dflags)+    then NoProfilingInfo+    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)++staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()+staticClosure pkg cl_label info payload+  = do dflags <- getDynFlags+       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits++foreignCall+        :: String+        -> [CmmParse (LocalReg, ForeignHint)]+        -> CmmParse CmmExpr+        -> [CmmParse (CmmExpr, ForeignHint)]+        -> Safety+        -> CmmReturnInfo+        -> PD (CmmParse ())+foreignCall conv_string results_code expr_code args_code safety ret+  = do  conv <- case conv_string of+          "C" -> return CCallConv+          "stdcall" -> return StdCallConv+          _ -> fail ("unknown calling convention: " ++ conv_string)+        return $ do+          dflags <- getDynFlags+          results <- sequence results_code+          expr <- expr_code+          args <- sequence args_code+          let+                  expr' = adjCallTarget dflags conv expr args+                  (arg_exprs, arg_hints) = unzip args+                  (res_regs,  res_hints) = unzip results+                  fc = ForeignConvention conv arg_hints res_hints ret+                  target = ForeignTarget expr' fc+          _ <- code $ emitForeignCall safety res_regs target arg_exprs+          return ()+++doReturn :: [CmmParse CmmExpr] -> CmmParse ()+doReturn exprs_code = do+  dflags <- getDynFlags+  exprs <- sequence exprs_code+  updfr_off <- getUpdFrameOff+  emit (mkReturnSimple dflags exprs updfr_off)++mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph+mkReturnSimple dflags actuals updfr_off =+  mkReturn dflags e actuals updfr_off+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)+                             (gcWord dflags))++doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()+doRawJump expr_code vols = do+  dflags <- getDynFlags+  expr <- expr_code+  updfr_off <- getUpdFrameOff+  emit (mkRawJump dflags expr updfr_off vols)++doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]+                -> [CmmParse CmmExpr] -> CmmParse ()+doJumpWithStack expr_code stk_code args_code = do+  dflags <- getDynFlags+  expr <- expr_code+  stk_args <- sequence stk_code+  args <- sequence args_code+  updfr_off <- getUpdFrameOff+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)++doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]+       -> CmmParse ()+doCall expr_code res_code args_code = do+  dflags <- getDynFlags+  expr <- expr_code+  args <- sequence args_code+  ress <- sequence res_code+  updfr_off <- getUpdFrameOff+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []+  emit c++adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]+              -> CmmExpr+-- On Windows, we have to add the '@N' suffix to the label when making+-- a call with the stdcall calling convention.+adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args+ | platformOS (targetPlatform dflags) == OSMinGW32+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))+                 -- c.f. CgForeignCall.emitForeignCall+adjCallTarget _ _ expr _+  = expr++primCall+        :: [CmmParse (CmmFormal, ForeignHint)]+        -> FastString+        -> [CmmParse CmmExpr]+        -> PD (CmmParse ())+primCall results_code name args_code+  = case lookupUFM callishMachOps name of+        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Just f  -> return $ do+                results <- sequence results_code+                args <- sequence args_code+                let (p, args') = f args+                code (emitPrimCall (map fst results) p args')++doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()+doStore rep addr_code val_code+  = do dflags <- getDynFlags+       addr <- addr_code+       val <- val_code+        -- if the specified store type does not match the type of the expr+        -- on the rhs, then we insert a coercion that will cause the type+        -- mismatch to be flagged by cmm-lint.  If we don't do this, then+        -- the store will happen at the wrong type, and the error will not+        -- be noticed.+       let val_width = typeWidth (cmmExprType dflags val)+           rep_width = typeWidth rep+       let coerce_val+                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]+                | otherwise              = val+       emitStore addr coerce_val++-- -----------------------------------------------------------------------------+-- If-then-else and boolean expressions++data BoolExpr+  = BoolExpr `BoolAnd` BoolExpr+  | BoolExpr `BoolOr`  BoolExpr+  | BoolNot BoolExpr+  | BoolTest CmmExpr++-- ToDo: smart constructors which simplify the boolean expression.++cmmIfThenElse cond then_part else_part likely = do+     then_id <- newBlockId+     join_id <- newBlockId+     c <- cond+     emitCond c then_id likely+     else_part+     emit (mkBranch join_id)+     emitLabel then_id+     then_part+     -- fall through to join+     emitLabel join_id++cmmRawIf cond then_id likely = do+    c <- cond+    emitCond c then_id likely++-- 'emitCond cond true_id'  emits code to test whether the cond is true,+-- branching to true_id if so, and falling through otherwise.+emitCond (BoolTest e) then_id likely = do+  else_id <- newBlockId+  emit (mkCbranch e then_id else_id likely)+  emitLabel else_id+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely+  | Just op' <- maybeInvertComparison op+  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)+emitCond (BoolNot e) then_id likely = do+  else_id <- newBlockId+  emitCond e else_id likely+  emit (mkBranch then_id)+  emitLabel else_id+emitCond (e1 `BoolOr` e2) then_id likely = do+  emitCond e1 then_id likely+  emitCond e2 then_id likely+emitCond (e1 `BoolAnd` e2) then_id likely = do+        -- we'd like to invert one of the conditionals here to avoid an+        -- extra branch instruction, but we can't use maybeInvertComparison+        -- here because we can't look too closely at the expression since+        -- we're in a loop.+  and_id <- newBlockId+  else_id <- newBlockId+  emitCond e1 and_id likely+  emit (mkBranch else_id)+  emitLabel and_id+  emitCond e2 then_id likely+  emitLabel else_id++-- -----------------------------------------------------------------------------+-- Source code notes++-- | Generate a source note spanning from "a" to "b" (inclusive), then+-- proceed with parsing. This allows debugging tools to reason about+-- locations in Cmm code.+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c+withSourceNote a b parse = do+  name <- getName+  case combineSrcSpans (getLoc a) (getLoc b) of+    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse+    _other           -> parse++-- -----------------------------------------------------------------------------+-- Table jumps++-- We use a simplified form of C-- switch statements for now.  A+-- switch statement always compiles to a table jump.  Each arm can+-- specify a list of values (not ranges), and there can be a single+-- default branch.  The range of the table is given either by the+-- optional range on the switch (eg. switch [0..7] {...}), or by+-- the minimum/maximum values from the branches.++doSwitch :: Maybe (Integer,Integer)+         -> CmmParse CmmExpr+         -> [([Integer],Either BlockId (CmmParse ()))]+         -> Maybe (CmmParse ()) -> CmmParse ()+doSwitch mb_range scrut arms deflt+   = do+        -- Compile code for the default branch+        dflt_entry <-+                case deflt of+                  Nothing -> return Nothing+                  Just e  -> do b <- forkLabelledCode e; return (Just b)++        -- Compile each case branch+        table_entries <- mapM emitArm arms+        let table = M.fromList (concat table_entries)++        dflags <- getDynFlags+        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range++        expr <- scrut+        -- ToDo: check for out of range and jump to default if necessary+        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)+   where+        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]+        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]+        emitArm (ints,Right code) = do+           blockid <- forkLabelledCode code+           return [ (i,blockid) | i <- ints ]++forkLabelledCode :: CmmParse () -> CmmParse BlockId+forkLabelledCode p = do+  (_,ag) <- getCodeScoped p+  l <- newBlockId+  emitOutOfLine l ag+  return l++-- -----------------------------------------------------------------------------+-- Putting it all together++-- The initial environment: we define some constants that the compiler+-- knows about here.+initEnv :: DynFlags -> Env+initEnv dflags = listToUFM [+  ( fsLit "SIZEOF_StgHeader",+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),+  ( fsLit "SIZEOF_StgInfoTable",+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))+  ]++parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)+parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do+  buf <- hGetStringBuffer filename+  let+        init_loc = mkRealSrcLoc (mkFastString filename) 1 1+        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }+                -- reset the lex_state: the Lexer monad leaves some stuff+                -- in there we don't want.+  case unPD cmmParse dflags init_state of+    PFailed pst ->+        return (getMessages pst dflags, Nothing)+    POk pst code -> do+        st <- initC+        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()+            (cmm,_) = runC dflags no_module st fcode+        let ms = getMessages pst dflags+        if (errorsFound dflags ms)+         then return (ms, Nothing)+         else return (ms, Just cmm)+  where+        no_module = panic "parseCmmFile: no module"+}
+ compiler/GHC/Cmm/Pipeline.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE BangPatterns #-}++module GHC.Cmm.Pipeline (+  -- | Converts C-- with an implicit stack and native C-- calls into+  -- optimized, CPS converted and native-call-less C--.  The latter+  -- C-- can be used to generate assembly.+  cmmPipeline+) where++import GhcPrelude++import GHC.Cmm+import GHC.Cmm.Lint+import GHC.Cmm.Info.Build+import GHC.Cmm.CommonBlockElim+import GHC.Cmm.Switch.Implement+import GHC.Cmm.ProcPoint+import GHC.Cmm.ContFlowOpt+import GHC.Cmm.LayoutStack+import GHC.Cmm.Sink+import GHC.Cmm.Dataflow.Collections++import UniqSupply+import DynFlags+import ErrUtils+import HscTypes+import Control.Monad+import Outputable+import GHC.Platform++-----------------------------------------------------------------------------+-- | Top level driver for C-- pipeline+-----------------------------------------------------------------------------++cmmPipeline+ :: HscEnv -- Compilation env including+           -- dynamic flags: -dcmm-lint -ddump-cmm-cps+ -> ModuleSRTInfo        -- Info about SRTs generated so far+ -> CmmGroup             -- Input C-- with Procedures+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--++cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $+  do let dflags = hsc_dflags hsc_env++     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog++     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)++     return (srtInfo, cmms)++  where forceRes (info, group) =+          info `seq` foldr (\decl r -> decl `seq` r) () group++        dflags = hsc_dflags hsc_env++cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])+cpsTop hsc_env proc =+    do+       ----------- Control-flow optimisations ----------------------------------++       -- The first round of control-flow optimisation speeds up the+       -- later passes by removing lots of empty blocks, so we do it+       -- even when optimisation isn't turned on.+       --+       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}+            return $ cmmCfgOptsProc splitting_proc_points proc+       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g++       let !TopInfo {stack_info=StackInfo { arg_space = entry_off+                                          , do_layout = do_layout }} = h++       ----------- Eliminate common blocks -------------------------------------+       g <- {-# SCC "elimCommonBlocks" #-}+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+                          Opt_D_dump_cmm_cbe "Post common block elimination"++       -- Any work storing block Labels must be performed _after_+       -- elimCommonBlocks++       ----------- Implement switches ------------------------------------------+       g <- {-# SCC "createSwitchPlans" #-}+            runUniqSM $ cmmImplementSwitchPlans dflags g+       dump Opt_D_dump_cmm_switch "Post switch plan" g++       ----------- Proc points -------------------------------------------------+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+       proc_points <-+          if splitting_proc_points+             then do+               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $+                  minimalProcPointSet (targetPlatform dflags) call_pps g+               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"+                     FormatCMM (ppr l $$ ppr pp $$ ppr g)+               return pp+             else+               return call_pps++       ----------- Layout the stack and manifest Sp ----------------------------+       (g, stackmaps) <-+            {-# SCC "layoutStack" #-}+            if do_layout+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+               else return (g, mapEmpty)+       dump Opt_D_dump_cmm_sp "Layout Stack" g++       ----------- Sink and inline assignments  --------------------------------+       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+            condPass Opt_CmmSink (cmmSink dflags) g+                     Opt_D_dump_cmm_sink "Sink assignments"++       ------------- CAF analysis ----------------------------------------------+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)++       g <- if splitting_proc_points+            then do+               ------------- Split into separate procedures -----------------------+               let pp_map = {-# SCC "procPointAnalysis" #-}+                            procPointAnalysis proc_points g+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"+                  FormatCMM (ppr pp_map)+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+                    splitAtProcPoints dflags l call_pps proc_points pp_map+                                      (CmmProc h l v g)+               dumps Opt_D_dump_cmm_split "Post splitting" g+               return g+             else do+               -- attach info tables to return points+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]++       ------------- Populate info tables with stack info -----------------+       g <- {-# SCC "setInfoTableStackMap" #-}+            return $ map (setInfoTableStackMap dflags stackmaps) g+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g++       ----------- Control-flow optimisations -----------------------------+       g <- {-# SCC "cmmCfgOpts(2)" #-}+            return $ if optLevel dflags >= 1+                     then map (cmmCfgOptsProc splitting_proc_points) g+                     else g+       g <- return (map removeUnreachableBlocksProc g)+            -- See Note [unreachable blocks]+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g++       return (cafEnv, g)++  where dflags = hsc_dflags hsc_env+        platform = targetPlatform dflags+        dump = dumpGraph dflags++        dumps flag name+           = mapM_ (dumpWith dflags flag name FormatCMM . ppr)++        condPass flag pass g dumpflag dumpname =+            if gopt flag dflags+               then do+                    g <- return $ pass g+                    dump dumpflag dumpname g+                    return g+               else return g++        -- we don't need to split proc points for the NCG, unless+        -- tablesNextToCode is off.  The latter is because we have no+        -- label to put on info tables for basic blocks that are not+        -- the entry point.+        splitting_proc_points = hscTarget dflags /= HscAsm+                             || not (tablesNextToCode dflags)+                             || -- Note [inconsistent-pic-reg]+                                usingInconsistentPicReg+        usingInconsistentPicReg+           = case (platformArch platform, platformOS platform, positionIndependent dflags)+             of   (ArchX86, OSDarwin, pic) -> pic+                  _                        -> False++-- Note [Sinking after stack layout]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- In the past we considered running sinking pass also before stack+-- layout, but after making some measurements we realized that:+--+--   a) running sinking only before stack layout produces slower+--      code than running sinking only before stack layout+--+--   b) running sinking both before and after stack layout produces+--      code that has the same performance as when running sinking+--      only after stack layout.+--+-- In other words sinking before stack layout doesn't buy as anything.+--+-- An interesting question is "why is it better to run sinking after+-- stack layout"? It seems that the major reason are stores and loads+-- generated by stack layout. Consider this code before stack layout:+--+--  c1E:+--      _c1C::P64 = R3;+--      _c1B::P64 = R2;+--      _c1A::P64 = R1;+--      I64[(young<c1D> + 8)] = c1D;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      R3 = _c1C::P64;+--      R2 = _c1B::P64;+--      R1 = _c1A::P64;+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- Stack layout pass will save all local variables live across a call+-- (_c1C, _c1B and _c1A in this example) on the stack just before+-- making a call and reload them from the stack after returning from a+-- call:+--+--  c1E:+--      _c1C::P64 = R3;+--      _c1B::P64 = R2;+--      _c1A::P64 = R1;+--      I64[Sp - 32] = c1D;+--      P64[Sp - 24] = _c1A::P64;+--      P64[Sp - 16] = _c1B::P64;+--      P64[Sp - 8] = _c1C::P64;+--      Sp = Sp - 32;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      _c1A::P64 = P64[Sp + 8];+--      _c1B::P64 = P64[Sp + 16];+--      _c1C::P64 = P64[Sp + 24];+--      R3 = _c1C::P64;+--      R2 = _c1B::P64;+--      R1 = _c1A::P64;+--      Sp = Sp + 32;+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- If we don't run sinking pass after stack layout we are basically+-- left with such code. However, running sinking on this code can lead+-- to significant improvements:+--+--  c1E:+--      I64[Sp - 32] = c1D;+--      P64[Sp - 24] = R1;+--      P64[Sp - 16] = R2;+--      P64[Sp - 8] = R3;+--      Sp = Sp - 32;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      R3 = P64[Sp + 24];+--      R2 = P64[Sp + 16];+--      R1 = P64[Sp + 8];+--      Sp = Sp + 32;+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- Now we only have 9 assignments instead of 15.+--+-- There is one case when running sinking before stack layout could+-- be beneficial. Consider this:+--+--   L1:+--      x = y+--      call f() returns L2+--   L2: ...x...y...+--+-- Since both x and y are live across a call to f, they will be stored+-- on the stack during stack layout and restored after the call:+--+--   L1:+--      x = y+--      P64[Sp - 24] = L2+--      P64[Sp - 16] = x+--      P64[Sp - 8]  = y+--      Sp = Sp - 24+--      call f() returns L2+--   L2:+--      y = P64[Sp + 16]+--      x = P64[Sp + 8]+--      Sp = Sp + 24+--      ...x...y...+--+-- However, if we run sinking before stack layout we would propagate x+-- to its usage place (both x and y must be local register for this to+-- be possible - global registers cannot be floated past a call):+--+--   L1:+--      x = y+--      call f() returns L2+--   L2: ...y...y...+--+-- Thus making x dead at the call to f(). If we ran stack layout now+-- we would generate less stores and loads:+--+--   L1:+--      x = y+--      P64[Sp - 16] = L2+--      P64[Sp - 8]  = y+--      Sp = Sp - 16+--      call f() returns L2+--   L2:+--      y = P64[Sp + 8]+--      Sp = Sp + 16+--      ...y...y...+--+-- But since we don't see any benefits from running sinking before stack+-- layout, this situation probably doesn't arise too often in practice.+--++{- Note [inconsistent-pic-reg]++On x86/Darwin, PIC is implemented by inserting a sequence like++    call 1f+ 1: popl %reg++at the proc entry point, and then referring to labels as offsets from+%reg.  If we don't split proc points, then we could have many entry+points in a proc that would need this sequence, and each entry point+would then get a different value for %reg.  If there are any join+points, then at the join point we don't have a consistent value for+%reg, so we don't know how to refer to labels.++Hence, on x86/Darwin, we have to split proc points, and then each proc+point will get its own PIC initialisation sequence.++This isn't an issue on x86/ELF, where the sequence is++    call 1f+ 1: popl %reg+    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg++so %reg always has a consistent value: the address of+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.++-}++{- Note [unreachable blocks]++The control-flow optimiser sometimes leaves unreachable blocks behind+containing junk code.  These aren't necessarily a problem, but+removing them is good because it might save time in the native code+generator later.++-}++runUniqSM :: UniqSM a -> IO a+runUniqSM m = do+  us <- mkSplitUniqSupply 'u'+  return (initUs_ us m)+++dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()+dumpGraph dflags flag name g = do+  when (gopt Opt_DoCmmLinting dflags) $ do_lint g+  dumpWith dflags flag name FormatCMM (ppr g)+ where+  do_lint g = case cmmLintGraph dflags g of+                 Just err -> do { fatalErrorMsg dflags err+                                ; ghcExit dflags 1+                                }+                 Nothing  -> return ()++dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+dumpWith dflags flag txt fmt sdoc = do+  dumpIfSet_dyn dflags flag txt fmt sdoc+  when (not (dopt flag dflags)) $+    -- If `-ddump-cmm-verbose -ddump-to-file` is specified,+    -- dump each Cmm pipeline stage output to a separate file.  #16930+    when (dopt Opt_D_dump_cmm_verbose dflags)+      $ dumpAction dflags (mkDumpStyle dflags alwaysQualify)+                   (dumpOptionsFromFlag flag) txt fmt sdoc+  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
+ compiler/GHC/Cmm/Ppr.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++----------------------------------------------------------------------------+--+-- Pretty-printing of Cmm as (a superset of) C--+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+--+-- This is where we walk over CmmNode emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs++module GHC.Cmm.Ppr+  ( module GHC.Cmm.Ppr.Decl+  , module GHC.Cmm.Ppr.Expr+  )+where++import GhcPrelude hiding (succ)++import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import DynFlags+import FastString+import Outputable+import GHC.Cmm.Ppr.Decl+import GHC.Cmm.Ppr.Expr+import Util++import BasicTypes+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph++-------------------------------------------------+-- Outputable instances++instance Outputable CmmStackInfo where+    ppr = pprStackInfo++instance Outputable CmmTopInfo where+    ppr = pprTopInfo+++instance Outputable (CmmNode e x) where+    ppr = pprNode++instance Outputable Convention where+    ppr = pprConvention++instance Outputable ForeignConvention where+    ppr = pprForeignConvention++instance Outputable ForeignTarget where+    ppr = pprForeignTarget++instance Outputable CmmReturnInfo where+    ppr = pprReturnInfo++instance Outputable (Block CmmNode C C) where+    ppr = pprBlock+instance Outputable (Block CmmNode C O) where+    ppr = pprBlock+instance Outputable (Block CmmNode O C) where+    ppr = pprBlock+instance Outputable (Block CmmNode O O) where+    ppr = pprBlock++instance Outputable (Graph CmmNode e x) where+    ppr = pprGraph++instance Outputable CmmGraph where+    ppr = pprCmmGraph++----------------------------------------------------------+-- Outputting types Cmm contains++pprStackInfo :: CmmStackInfo -> SDoc+pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =+  text "arg_space: " <> ppr arg_space <+>+  text "updfr_space: " <> ppr updfr_space++pprTopInfo :: CmmTopInfo -> SDoc+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =+  vcat [text "info_tbls: " <> ppr info_tbl,+        text "stack_info: " <> ppr stack_info]++----------------------------------------------------------+-- Outputting blocks and graphs++pprBlock :: IndexedCO x SDoc SDoc ~ SDoc+         => Block CmmNode e x -> IndexedCO e SDoc SDoc+pprBlock block+    = foldBlockNodesB3 ( ($$) . ppr+                       , ($$) . (nest 4) . ppr+                       , ($$) . (nest 4) . ppr+                       )+                       block+                       empty++pprGraph :: Graph CmmNode e x -> SDoc+pprGraph GNil = empty+pprGraph (GUnit block) = ppr block+pprGraph (GMany entry body exit)+   = text "{"+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)+  $$ text "}"+  where pprMaybeO :: Outputable (Block CmmNode e x)+                  => MaybeO ex (Block CmmNode e x) -> SDoc+        pprMaybeO NothingO = empty+        pprMaybeO (JustO block) = ppr block++pprCmmGraph :: CmmGraph -> SDoc+pprCmmGraph g+   = text "{" <> text "offset"+  $$ nest 2 (vcat $ map ppr blocks)+  $$ text "}"+  where blocks = revPostorder g+    -- revPostorder has the side-effect of discarding unreachable code,+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can+    -- sometimes be confusing.++---------------------------------------------+-- Outputting CmmNode and types which it contains++pprConvention :: Convention -> SDoc+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"+pprConvention (NativeReturn {})     = text "<native-ret-convention>"+pprConvention  Slow                 = text "<slow-convention>"+pprConvention  GC                   = text "<gc-convention>"++pprForeignConvention :: ForeignConvention -> SDoc+pprForeignConvention (ForeignConvention c args res ret) =+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret++pprReturnInfo :: CmmReturnInfo -> SDoc+pprReturnInfo CmmMayReturn = empty+pprReturnInfo CmmNeverReturns = text "never returns"++pprForeignTarget :: ForeignTarget -> SDoc+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn+  where+        ppr_target :: CmmExpr -> SDoc+        ppr_target t@(CmmLit _) = ppr t+        ppr_target fn'          = parens (ppr fn')++pprForeignTarget (PrimTarget op)+ -- HACK: We're just using a ForeignLabel to get this printed, the label+ --       might not really be foreign.+ = ppr+               (CmmLabel (mkForeignLabel+                         (mkFastString (show op))+                         Nothing ForeignLabelInThisPackage IsFunction))++pprNode :: CmmNode e x -> SDoc+pprNode node = pp_node <+> pp_debug+  where+    pp_node :: SDoc+    pp_node = sdocWithDynFlags $ \dflags -> case node of+      -- label:+      CmmEntry id tscope -> lbl <> colon <+>+         (sdocWithDynFlags $ \dflags ->+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))+          where+            lbl = if gopt Opt_SuppressUniques dflags+                then text "_lbl_"+                else ppr id++      -- // text+      CmmComment s -> text "//" <+> ftext s++      -- //tick bla<...>+      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $+                   text "//tick" <+> ppr t++      -- unwind reg = expr;+      CmmUnwind regs ->+          text "unwind "+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi++      -- reg = expr;+      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi++      -- rep[lv] = expr;+      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi+          where+            rep = sdocWithDynFlags $ \dflags ->+                  ppr ( cmmExprType dflags expr )++      -- call "ccall" foo(x, y)[r1, r2];+      -- ToDo ppr volatile+      CmmUnsafeForeignCall target results args ->+          hsep [ ppUnless (null results) $+                    parens (commafy $ map ppr results) <+> equals,+                 text "call",+                 ppr target <> parens (commafy $ map ppr args) <> semi]++      -- goto label;+      CmmBranch ident -> text "goto" <+> ppr ident <> semi++      -- if (expr) goto t; else goto f;+      CmmCondBranch expr t f l ->+          hsep [ text "if"+               , parens(ppr expr)+               , case l of+                   Nothing -> empty+                   Just b -> parens (text "likely:" <+> ppr b)+               , text "goto"+               , ppr t <> semi+               , text "else goto"+               , ppr f <> semi+               ]++      CmmSwitch expr ids ->+          hang (hsep [ text "switch"+                     , range+                     , if isTrivialCmmExpr expr+                       then ppr expr+                       else parens (ppr expr)+                     , text "{"+                     ])+             4 (vcat (map ppCase cases) $$ def) $$ rbrace+          where+            (cases, mbdef) = switchTargetsFallThrough ids+            ppCase (is,l) = hsep+                            [ text "case"+                            , commafy $ map integer is+                            , text ": goto"+                            , ppr l <> semi+                            ]+            def | Just l <- mbdef = hsep+                            [ text "default:"+                            , braces (text "goto" <+> ppr l <> semi)+                            ]+                | otherwise = empty++            range = brackets $ hsep [integer lo, text "..", integer hi]+              where (lo,hi) = switchTargetsRange ids++      CmmCall tgt k regs out res updfr_off ->+          hcat [ text "call", space+               , pprFun tgt, parens (interpp'SP regs), space+               , returns <+>+                 text "args: " <> ppr out <> comma <+>+                 text "res: " <> ppr res <> comma <+>+                 text "upd: " <> ppr updfr_off+               , semi ]+          where pprFun f@(CmmLit _) = ppr f+                pprFun f = parens (ppr f)++                returns+                  | Just r <- k = text "returns to" <+> ppr r <> comma+                  | otherwise   = empty++      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->+          hcat $ if i then [text "interruptible", space] else [] +++               [ text "foreign call", space+               , ppr t, text "(...)", space+               , text "returns to" <+> ppr s+                    <+> text "args:" <+> parens (ppr as)+                    <+> text "ress:" <+> parens (ppr rs)+               , text "ret_args:" <+> ppr a+               , text "ret_off:" <+> ppr u+               , semi ]++    pp_debug :: SDoc+    pp_debug =+      if not debugIsOn then empty+      else case node of+             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"+             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"+             CmmTick {}              -> empty+             CmmUnwind {}            -> text "  // CmmUnwind"+             CmmAssign {}            -> text "  // CmmAssign"+             CmmStore {}             -> text "  // CmmStore"+             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"+             CmmBranch {}            -> text "  // CmmBranch"+             CmmCondBranch {}        -> text "  // CmmCondBranch"+             CmmSwitch {}            -> text "  // CmmSwitch"+             CmmCall {}              -> text "  // CmmCall"+             CmmForeignCall {}       -> text "  // CmmForeignCall"++    commafy :: [SDoc] -> SDoc+    commafy xs = hsep $ punctuate comma xs
+ compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -0,0 +1,169 @@+----------------------------------------------------------------------------+--+-- Pretty-printing of common Cmm types+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs+--++{-# OPTIONS_GHC -fno-warn-orphans #-}+module GHC.Cmm.Ppr.Decl+    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic+    )+where++import GhcPrelude++import GHC.Cmm.Ppr.Expr+import GHC.Cmm++import DynFlags+import Outputable+import FastString++import Data.List+import System.IO++import qualified Data.ByteString as BS+++pprCmms :: (Outputable info, Outputable g)+        => [GenCmmGroup CmmStatics info g] -> SDoc+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))+        where+          separator = space $$ text "-------------------" $$ space++writeCmms :: (Outputable info, Outputable g)+          => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()+writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)++-----------------------------------------------------------------------------++instance (Outputable d, Outputable info, Outputable i)+      => Outputable (GenCmmDecl d info i) where+    ppr t = pprTop t++instance Outputable CmmStatics where+    ppr = pprStatics++instance Outputable CmmStatic where+    ppr = pprStatic++instance Outputable CmmInfoTable where+    ppr = pprInfoTable+++-----------------------------------------------------------------------------++pprCmmGroup :: (Outputable d, Outputable info, Outputable g)+            => GenCmmGroup d info g -> SDoc+pprCmmGroup tops+    = vcat $ intersperse blankLine $ map pprTop tops++-- --------------------------------------------------------------------------+-- Top level `procedure' blocks.+--+pprTop :: (Outputable d, Outputable info, Outputable i)+       => GenCmmDecl d info i -> SDoc++pprTop (CmmProc info lbl live graph)++  = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live+         , nest 8 $ lbrace <+> ppr info $$ rbrace+         , nest 4 $ ppr graph+         , rbrace ]++-- --------------------------------------------------------------------------+-- We follow [1], 4.5+--+--      section "data" { ... }+--+pprTop (CmmData section ds) =+    (hang (pprSection section <+> lbrace) 4 (ppr ds))+    $$ rbrace++-- --------------------------------------------------------------------------+-- Info tables.++pprInfoTable :: CmmInfoTable -> SDoc+pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep+                           , cit_prof = prof_info+                           , cit_srt = srt })+  = vcat [ text "label: " <> ppr lbl+         , text "rep: " <> ppr rep+         , case prof_info of+             NoProfilingInfo -> empty+             ProfilingInfo ct cd ->+               vcat [ text "type: " <> text (show (BS.unpack ct))+                    , text "desc: " <> text (show (BS.unpack cd)) ]+         , text "srt: " <> ppr srt ]++instance Outputable ForeignHint where+  ppr NoHint     = empty+  ppr SignedHint = quotes(text "signed")+--  ppr AddrHint   = quotes(text "address")+-- Temp Jan08+  ppr AddrHint   = (text "PtrHint")++-- --------------------------------------------------------------------------+-- Static data.+--      Strings are printed as C strings, and we print them as I8[],+--      following C--+--+pprStatics :: CmmStatics -> SDoc+pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)++pprStatic :: CmmStatic -> SDoc+pprStatic s = case s of+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')++-- --------------------------------------------------------------------------+-- data sections+--+pprSection :: Section -> SDoc+pprSection (Section t suffix) =+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)+  where+    section = text "section"++pprSectionType :: SectionType -> SDoc+pprSectionType s = doubleQuotes (ptext t)+ where+  t = case s of+    Text              -> sLit "text"+    Data              -> sLit "data"+    ReadOnlyData      -> sLit "readonly"+    ReadOnlyData16    -> sLit "readonly16"+    RelocatableReadOnlyData+                      -> sLit "relreadonly"+    UninitialisedData -> sLit "uninitialised"+    CString           -> sLit "cstring"+    OtherSection s'   -> sLit s' -- Not actually a literal though.
+ compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -0,0 +1,286 @@+----------------------------------------------------------------------------+--+-- Pretty-printing of common Cmm types+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs+--++{-# OPTIONS_GHC -fno-warn-orphans #-}+module GHC.Cmm.Ppr.Expr+    ( pprExpr, pprLit+    )+where++import GhcPrelude++import GHC.Cmm.Expr++import Outputable+import DynFlags++import Data.Maybe+import Numeric ( fromRat )++-----------------------------------------------------------------------------++instance Outputable CmmExpr where+    ppr e = pprExpr e++instance Outputable CmmReg where+    ppr e = pprReg e++instance Outputable CmmLit where+    ppr l = pprLit l++instance Outputable LocalReg where+    ppr e = pprLocalReg e++instance Outputable Area where+    ppr e = pprArea e++instance Outputable GlobalReg where+    ppr e = pprGlobalReg e++-- --------------------------------------------------------------------------+-- Expressions+--++pprExpr :: CmmExpr -> SDoc+pprExpr e+    = sdocWithDynFlags $ \dflags ->+      case e of+        CmmRegOff reg i ->+                pprExpr (CmmMachOp (MO_Add rep)+                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])+                where rep = typeWidth (cmmRegType dflags reg)+        CmmLit lit -> pprLit lit+        _other     -> pprExpr1 e++-- Here's the precedence table from GHC.Cmm.Parser:+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+-- %left '|'+-- %left '^'+-- %left '&'+-- %left '>>' '<<'+-- %left '-' '+'+-- %left '/' '*' '%'+-- %right '~'++-- We just cope with the common operators for now, the rest will get+-- a default conservative behaviour.++-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op+   = pprExpr7 x <+> doc <+> pprExpr7 y+pprExpr1 e = pprExpr7 e++infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc++infixMachOp1 (MO_Eq     _) = Just (text "==")+infixMachOp1 (MO_Ne     _) = Just (text "!=")+infixMachOp1 (MO_Shl    _) = Just (text "<<")+infixMachOp1 (MO_U_Shr  _) = Just (text ">>")+infixMachOp1 (MO_U_Ge   _) = Just (text ">=")+infixMachOp1 (MO_U_Le   _) = Just (text "<=")+infixMachOp1 (MO_U_Gt   _) = Just (char '>')+infixMachOp1 (MO_U_Lt   _) = Just (char '<')+infixMachOp1 _             = Nothing++-- %left '-' '+'+pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0+   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op+   = pprExpr7 x <+> doc <+> pprExpr8 y+pprExpr7 e = pprExpr8 e++infixMachOp7 (MO_Add _)  = Just (char '+')+infixMachOp7 (MO_Sub _)  = Just (char '-')+infixMachOp7 _           = Nothing++-- %left '/' '*' '%'+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op+   = pprExpr8 x <+> doc <+> pprExpr9 y+pprExpr8 e = pprExpr9 e++infixMachOp8 (MO_U_Quot _) = Just (char '/')+infixMachOp8 (MO_Mul _)    = Just (char '*')+infixMachOp8 (MO_U_Rem _)  = Just (char '%')+infixMachOp8 _             = Nothing++pprExpr9 :: CmmExpr -> SDoc+pprExpr9 e =+   case e of+        CmmLit    lit       -> pprLit1 lit+        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)+        CmmReg    reg       -> ppr reg+        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)+        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)+        CmmMachOp mop args  -> genMachOp mop args++genMachOp :: MachOp -> [CmmExpr] -> SDoc+genMachOp mop args+   | Just doc <- infixMachOp mop = case args of+        -- dyadic+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y++        -- unary+        [x]   -> doc <> pprExpr9 x++        _     -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"+                          (pprMachOp mop <+>+                            parens (hcat $ punctuate comma (map pprExpr args)))+                          empty++   | isJust (infixMachOp1 mop)+   || isJust (infixMachOp7 mop)+   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))++   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))+        where ppr_op = text (map (\c -> if c == ' ' then '_' else c)+                                 (show mop))+                -- replace spaces in (show mop) with underscores,++--+-- Unsigned ops on the word size of the machine get nice symbols.+-- All else get dumped in their ugly format.+--+infixMachOp :: MachOp -> Maybe SDoc+infixMachOp mop+        = case mop of+            MO_And    _ -> Just $ char '&'+            MO_Or     _ -> Just $ char '|'+            MO_Xor    _ -> Just $ char '^'+            MO_Not    _ -> Just $ char '~'+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)+            _ -> Nothing++-- --------------------------------------------------------------------------+-- Literals.+--  To minimise line noise we adopt the convention that if the literal+--  has the natural machine word size, we do not append the type+--+pprLit :: CmmLit -> SDoc+pprLit lit = sdocWithDynFlags $ \dflags ->+             case lit of+    CmmInt i rep ->+        hcat [ (if i < 0 then parens else id)(integer i)+             , ppUnless (rep == wordWidth dflags) $+               space <> dcolon <+> ppr rep ]++    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]+    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'+    CmmLabel clbl      -> ppr clbl+    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i+    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'+                                  <> ppr clbl2 <> ppr_offset i+    CmmBlock id        -> ppr id+    CmmHighStackMark -> text "<highSp>"++pprLit1 :: CmmLit -> SDoc+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)+pprLit1 lit                  = pprLit lit++ppr_offset :: Int -> SDoc+ppr_offset i+    | i==0      = empty+    | i>=0      = char '+' <> int i+    | otherwise = char '-' <> int (-i)++-- --------------------------------------------------------------------------+-- Registers, whether local (temps) or global+--+pprReg :: CmmReg -> SDoc+pprReg r+    = case r of+        CmmLocal  local  -> pprLocalReg  local+        CmmGlobal global -> pprGlobalReg global++--+-- We only print the type of the local reg if it isn't wordRep+--+pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->+--   = ppr rep <> char '_' <> ppr uniq+-- Temp Jan08+    char '_' <> pprUnique dflags uniq <>+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh+                    then dcolon <> ptr <> ppr rep+                    else dcolon <> ptr <> ppr rep)+   where+     pprUnique dflags unique =+        if gopt Opt_SuppressUniques dflags+            then text "_locVar_"+            else ppr unique+     ptr = empty+         --if isGcPtrType rep+         --      then doubleQuotes (text "ptr")+         --      else empty++-- Stack areas+pprArea :: Area -> SDoc+pprArea Old        = text "old"+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]++-- needs to be kept in syn with CmmExpr.hs.GlobalReg+--+pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg gr+    = case gr of+        VanillaReg n _ -> char 'R' <> int n+-- Temp Jan08+--        VanillaReg n VNonGcPtr -> char 'R' <> int n+--        VanillaReg n VGcPtr    -> char 'P' <> int n+        FloatReg   n   -> char 'F' <> int n+        DoubleReg  n   -> char 'D' <> int n+        LongReg    n   -> char 'L' <> int n+        XmmReg     n   -> text "XMM" <> int n+        YmmReg     n   -> text "YMM" <> int n+        ZmmReg     n   -> text "ZMM" <> int n+        Sp             -> text "Sp"+        SpLim          -> text "SpLim"+        Hp             -> text "Hp"+        HpLim          -> text "HpLim"+        MachSp         -> text "MachSp"+        UnwindReturnReg-> text "UnwindReturnReg"+        CCCS           -> text "CCCS"+        CurrentTSO     -> text "CurrentTSO"+        CurrentNursery -> text "CurrentNursery"+        HpAlloc        -> text "HpAlloc"+        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+        GCEnter1       -> text "stg_gc_enter_1"+        GCFun          -> text "stg_gc_fun"+        BaseReg        -> text "BaseReg"+        PicBaseReg     -> text "PicBaseReg"++-----------------------------------------------------------------------------++commafy :: [SDoc] -> SDoc+commafy xs = fsep $ punctuate comma xs
+ compiler/GHC/Cmm/ProcPoint.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Cmm.ProcPoint+    ( ProcPointSet, Status(..)+    , callProcPoints, minimalProcPointSet+    , splitAtProcPoints, procPointAnalysis+    , attachContInfoTables+    )+where++import GhcPrelude hiding (last, unzip, succ, zip)++import DynFlags+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Cmm.Ppr () -- For Outputable instances+import GHC.Cmm.Utils+import GHC.Cmm.Info+import GHC.Cmm.Liveness+import GHC.Cmm.Switch+import Data.List (sortBy)+import Maybes+import Control.Monad+import Outputable+import GHC.Platform+import UniqSupply+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label++-- Compute a minimal set of proc points for a control-flow graph.++-- Determine a protocol for each proc point (which live variables will+-- be passed as arguments and which will be on the stack).++{-+A proc point is a basic block that, after CPS transformation, will+start a new function.  The entry block of the original function is a+proc point, as is the continuation of each function call.+A third kind of proc point arises if we want to avoid copying code.+Suppose we have code like the following:++  f() {+    if (...) { ..1..; call foo(); ..2..}+    else     { ..3..; call bar(); ..4..}+    x = y + z;+    return x;+  }++The statement 'x = y + z' can be reached from two different proc+points: the continuations of foo() and bar().  We would prefer not to+put a copy in each continuation; instead we would like 'x = y + z' to+be the start of a new procedure to which the continuations can jump:++  f_cps () {+    if (...) { ..1..; push k_foo; jump foo_cps(); }+    else     { ..3..; push k_bar; jump bar_cps(); }+  }+  k_foo() { ..2..; jump k_join(y, z); }+  k_bar() { ..4..; jump k_join(y, z); }+  k_join(y, z) { x = y + z; return x; }++You might think then that a criterion to make a node a proc point is+that it is directly reached by two distinct proc points.  (Note+[Direct reachability].)  But this criterion is a bit too simple; for+example, 'return x' is also reached by two proc points, yet there is+no point in pulling it out of k_join.  A good criterion would be to+say that a node should be made a proc point if it is reached by a set+of proc points that is different than its immediate dominator.  NR+believes this criterion can be shown to produce a minimum set of proc+points, and given a dominator tree, the proc points can be chosen in+time linear in the number of blocks.  Lacking a dominator analysis,+however, we turn instead to an iterative solution, starting with no+proc points and adding them according to these rules:++  1. The entry block is a proc point.+  2. The continuation of a call is a proc point.+  3. A node is a proc point if it is directly reached by more proc+     points than one of its predecessors.++Because we don't understand the problem very well, we apply rule 3 at+most once per iteration, then recompute the reachability information.+(See Note [No simple dataflow].)  The choice of the new proc point is+arbitrary, and I don't know if the choice affects the final solution,+so I don't know if the number of proc points chosen is the+minimum---but the set will be minimal.++++Note [Proc-point analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~++Given a specified set of proc-points (a set of block-ids), "proc-point+analysis" figures out, for every block, which proc-point it belongs to.+All the blocks belonging to proc-point P will constitute a single+top-level C procedure.++A non-proc-point block B "belongs to" a proc-point P iff B is+reachable from P without going through another proc-point.++Invariant: a block B should belong to at most one proc-point; if it+belongs to two, that's a bug.++Note [Non-existing proc-points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++On some architectures it might happen that the list of proc-points+computed before stack layout pass will be invalidated by the stack+layout. This will happen if stack layout removes from the graph+blocks that were determined to be proc-points. Later on in the pipeline+we use list of proc-points to perform [Proc-point analysis], but+if a proc-point does not exist anymore then we will get compiler panic.+See #8205.+-}++type ProcPointSet = LabelSet++data Status+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block+  | ProcPoint               -- this block is itself a proc point++instance Outputable Status where+  ppr (ReachedBy ps)+      | setNull ps = text "<not-reached>"+      | otherwise = text "reached by" <+>+                    (hsep $ punctuate comma $ map ppr $ setElems ps)+  ppr ProcPoint = text "<procpt>"++--------------------------------------------------+-- Proc point analysis++-- Once you know what the proc-points are, figure out+-- what proc-points each block is reachable from+-- See Note [Proc-point analysis]+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints+  where+    initProcPoints =+        mkFactBase+            procPointLattice+            [ (id, ProcPoint)+            | id <- setElems procPoints+            -- See Note [Non-existing proc-points]+            , id `setMember` labelsInGraph+            ]+    labelsInGraph = labelsDefined graph++procPointTransfer :: TransferFun Status+procPointTransfer block facts =+    let label = entryLabel block+        !fact = case getFact procPointLattice label facts of+            ProcPoint -> ReachedBy $! setSingleton label+            f -> f+        result = map (\id -> (id, fact)) (successors block)+    in mkFactBase procPointLattice result++procPointLattice :: DataflowLattice Status+procPointLattice = DataflowLattice unreached add_to+  where+    unreached = ReachedBy setEmpty+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))+        | setSize union > setSize p = Changed (ReachedBy union)+        | otherwise = NotChanged (ReachedBy p)+      where+        union = setUnion p' p++----------------------------------------------------------------------++-- It is worth distinguishing two sets of proc points: those that are+-- induced by calls in the original graph and those that are+-- introduced because they're reachable from multiple proc points.+--+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].+callProcPoints      :: CmmGraph -> ProcPointSet+callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g+  where add :: LabelSet -> CmmBlock -> LabelSet+        add set b = case lastNode b of+                      CmmCall {cml_cont = Just k} -> setInsert k set+                      CmmForeignCall {succ=k}     -> setInsert k set+                      _ -> set++minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph+                    -> UniqSM ProcPointSet+-- Given the set of successors of calls (which must be proc-points)+-- figure out the minimal set of necessary proc-points+minimalProcPointSet platform callProcPoints g+  = extendPPSet platform g (revPostorder g) callProcPoints++extendPPSet+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet+extendPPSet platform g blocks procPoints =+    let env = procPointAnalysis procPoints g+        add pps block = let id = entryLabel block+                        in  case mapLookup id env of+                              Just ProcPoint -> setInsert id pps+                              _ -> pps+        procPoints' = foldlGraphBlocks add setEmpty g+        newPoints = mapMaybe ppSuccessor blocks+        newPoint  = listToMaybe newPoints+        ppSuccessor b =+            let nreached id = case mapLookup id env `orElse`+                                    pprPanic "no ppt" (ppr id <+> ppr b) of+                                ProcPoint -> 1+                                ReachedBy ps -> setSize ps+                block_procpoints = nreached (entryLabel b)+                -- | Looking for a successor of b that is reached by+                -- more proc points than b and is not already a proc+                -- point.  If found, it can become a proc point.+                newId succ_id = not (setMember succ_id procPoints') &&+                                nreached succ_id > block_procpoints+            in  listToMaybe $ filter newId $ successors b++    in case newPoint of+         Just id ->+             if setMember id procPoints'+                then panic "added old proc pt"+                else extendPPSet platform g blocks (setInsert id procPoints')+         Nothing -> return procPoints'+++-- At this point, we have found a set of procpoints, each of which should be+-- the entry point of a procedure.+-- Now, we create the procedure for each proc point,+-- which requires that we:+-- 1. build a map from proc points to the blocks reachable from the proc point+-- 2. turn each branch to a proc point into a jump+-- 3. turn calls and returns into jumps+-- 4. build info tables for the procedures -- and update the info table for+--    the SRTs in the entry procedure as well.+-- Input invariant: A block should only be reachable from a single ProcPoint.+-- ToDo: use the _ret naming convention that the old code generator+-- used. -- EZY+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->+                     CmmDecl -> UniqSM [CmmDecl]+splitAtProcPoints dflags entry_label callPPs procPoints procMap+                  (CmmProc (TopInfo {info_tbls = info_tbls})+                           top_l _ g@(CmmGraph {g_entry=entry})) =+  do -- Build a map from procpoints to the blocks they reach+     let add_block+             :: LabelMap (LabelMap CmmBlock)+             -> CmmBlock+             -> LabelMap (LabelMap CmmBlock)+         add_block graphEnv b =+           case mapLookup bid procMap of+             Just ProcPoint -> add graphEnv bid bid b+             Just (ReachedBy set) ->+               case setElems set of+                 []   -> graphEnv+                 [id] -> add graphEnv id bid b+                 _    -> panic "Each block should be reachable from only one ProcPoint"+             Nothing -> graphEnv+           where bid = entryLabel b+         add graphEnv procId bid b = mapInsert procId graph' graphEnv+               where graph  = mapLookup procId graphEnv `orElse` mapEmpty+                     graph' = mapInsert bid b graph++     let liveness = cmmGlobalLiveness dflags g+     let ppLiveness pp = filter isArgReg $+                         regSetToList $+                         expectJust "ppLiveness" $ mapLookup pp liveness++     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g++     -- Build a map from proc point BlockId to pairs of:+     --  * Labels for their new procedures+     --  * Labels for the info tables of their new procedures (only if+     --    the proc point is a callPP)+     -- Due to common blockification, we may overestimate the set of procpoints.+     let add_label map pp = mapInsert pp lbls map+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>+                                                    Just info_table_lbl)+                      where block_lbl      = blockLbl pp+                            info_table_lbl = infoTblLbl pp++         procLabels :: LabelMap (CLabel, Maybe CLabel)+         procLabels = foldl' add_label mapEmpty+                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))++     -- In each new graph, add blocks jumping off to the new procedures,+     -- and replace branches to procpoints with branches to the jump-off blocks+     let add_jump_block+             :: (LabelMap Label, [CmmBlock])+             -> (Label, CLabel)+             -> UniqSM (LabelMap Label, [CmmBlock])+         add_jump_block (env, bs) (pp, l) =+           do bid <- liftM mkBlockId getUniqueM+              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump+                  live = ppLiveness pp+                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0+              return (mapInsert pp bid env, b : bs)++         add_jumps+             :: LabelMap CmmGraph+             -> (Label, LabelMap CmmBlock)+             -> UniqSM (LabelMap CmmGraph)+         add_jumps newGraphEnv (ppId, blockEnv) =+           do let needed_jumps = -- find which procpoints we currently branch to+                    mapFoldr add_if_branch_to_pp [] blockEnv+                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]+                  add_if_branch_to_pp block rst =+                    case lastNode block of+                      CmmBranch id          -> add_if_pp id rst+                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)+                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids+                      _                     -> rst++                  -- when jumping to a PP that has an info table, if+                  -- tablesNextToCode is off we must jump to the entry+                  -- label instead.+                  jump_label (Just info_lbl) _+                             | tablesNextToCode dflags = info_lbl+                             | otherwise               = toEntryLbl info_lbl+                  jump_label Nothing         block_lbl = block_lbl++                  add_if_pp id rst = case mapLookup id procLabels of+                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst+                                       Nothing                 -> rst+              (jumpEnv, jumpBlocks) <-+                 foldM add_jump_block (mapEmpty, []) needed_jumps+                  -- update the entry block+              let b = expectJust "block in env" $ mapLookup ppId blockEnv+                  blockEnv' = mapInsert ppId b blockEnv+                  -- replace branches to procpoints with branches to jumps+                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'+                  -- add the jump blocks to the graph+                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks+              let g' = ofBlockMap ppId blockEnv'''+              -- pprTrace "g' pre jumps" (ppr g') $ do+              return (mapInsert ppId g' newGraphEnv)++     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv++     let to_proc (bid, g)+             | bid == entry+             =  CmmProc (TopInfo {info_tbls  = info_tbls,+                                  stack_info = stack_info})+                        top_l live g'+             | otherwise+             = case expectJust "pp label" $ mapLookup bid procLabels of+                 (lbl, Just info_lbl)+                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)+                                        , stack_info=stack_info})+                               lbl live g'+                 (lbl, Nothing)+                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})+                               lbl live g'+                where+                 g' = replacePPIds g+                 live = ppLiveness (g_entry g')+                 stack_info = StackInfo { arg_space = 0+                                        , updfr_space =  Nothing+                                        , do_layout = True }+                               -- cannot use panic, this is printed by -ddump-cmm++         -- References to procpoint IDs can now be replaced with the+         -- infotable's label+         replacePPIds g = {-# SCC "replacePPIds" #-}+                          mapGraphNodes (id, mapExp repl, mapExp repl) g+           where repl e@(CmmLit (CmmBlock bid)) =+                   case mapLookup bid procLabels of+                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)+                     _ -> e+                 repl e = e++     -- The C back end expects to see return continuations before the+     -- call sites.  Here, we sort them in reverse order -- it gets+     -- reversed later.+     let (_, block_order) =+             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)+                   (revPostorder g)+         add_block_num (i, map) block =+           (i + 1, mapInsert (entryLabel block) i map)+         sort_fn (bid, _) (bid', _) =+           compare (expectJust "block_order" $ mapLookup bid  block_order)+                   (expectJust "block_order" $ mapLookup bid' block_order)+     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv+     return -- pprTrace "procLabels" (ppr procLabels)+            -- pprTrace "splitting graphs" (ppr procs)+            procs+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]++-- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a+-- recursive lookup, see comment below.+replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph+replaceBranches env cmmg+  = {-# SCC "replaceBranches" #-}+    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg+  where+    f block = replaceLastNode block $ last (lastNode block)++    last :: CmmNode O C -> CmmNode O C+    last (CmmBranch id)          = CmmBranch (lookup id)+    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l+    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)+    last l@(CmmCall {})          = l { cml_cont = Nothing }+            -- NB. remove the continuation of a CmmCall, since this+            -- label will now be in a different CmmProc.  Not only+            -- is this tidier, it stops CmmLint from complaining.+    last l@(CmmForeignCall {})   = l+    lookup id = fmap lookup (mapLookup id env) `orElse` id+            -- XXX: this is a recursive lookup, it follows chains+            -- until the lookup returns Nothing, at which point we+            -- return the last BlockId++-- --------------------------------------------------------------+-- Not splitting proc points: add info tables for continuations++attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl+attachContInfoTables call_proc_points (CmmProc top_info top_l live g)+ = CmmProc top_info{info_tbls = info_tbls'} top_l live g+ where+   info_tbls' = mapUnion (info_tbls top_info) $+                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))+                            | l <- setElems call_proc_points+                            , l /= g_entry g ]+attachContInfoTables _ other_decl+ = other_decl++----------------------------------------------------------------++{-+Note [Direct reachability]++Block B is directly reachable from proc point P iff control can flow+from P to B without passing through an intervening proc point.+-}++----------------------------------------------------------------++{-+Note [No simple dataflow]++Sadly, it seems impossible to compute the proc points using a single+dataflow pass.  One might attempt to use this simple lattice:++  data Location = Unknown+                | InProc BlockId -- node is in procedure headed by the named proc point+                | ProcPoint      -- node is itself a proc point++At a join, a node in two different blocks becomes a proc point.+The difficulty is that the change of information during iterative+computation may promote a node prematurely.  Here's a program that+illustrates the difficulty:++  f () {+  entry:+    ....+  L1:+    if (...) { ... }+    else { ... }++  L2: if (...) { g(); goto L1; }+      return x + y;+  }++The only proc-point needed (besides the entry) is L1.  But in an+iterative analysis, consider what happens to L2.  On the first pass+through, it rises from Unknown to 'InProc entry', but when L1 is+promoted to a proc point (because it's the successor of g()), L1's+successors will be promoted to 'InProc L1'.  The problem hits when the+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.+The join operation makes it a proc point when in fact it needn't be,+because its immediate dominator L1 is already a proc point and there+are no other proc points that directly reach L2.+-}++++{- Note [Separate Adams optimization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It may be worthwhile to attempt the Adams optimization by rewriting+the graph before the assignment of proc-point protocols.  Here are a+couple of rules:++  g() returns to k;                    g() returns to L;+  k: CopyIn c ress; goto L:+   ...                        ==>        ...+  L: // no CopyIn node here            L: CopyIn c ress;+++And when c == c' and ress == ress', this also:++  g() returns to k;                    g() returns to L;+  k: CopyIn c ress; goto L:+   ...                        ==>        ...+  L: CopyIn c' ress'                   L: CopyIn c' ress' ;++In both cases the goal is to eliminate k.+-}
+ compiler/GHC/Cmm/Sink.hs view
@@ -0,0 +1,854 @@+{-# LANGUAGE GADTs #-}+module GHC.Cmm.Sink (+     cmmSink+  ) where++import GhcPrelude++import GHC.Cmm+import GHC.Cmm.Opt+import GHC.Cmm.Liveness+import GHC.Cmm.Utils+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Platform.Regs+import GHC.Platform (isARM, platformArch)++import DynFlags+import Unique+import UniqFM++import qualified Data.IntSet as IntSet+import Data.List (partition)+import qualified Data.Set as Set+import Data.Maybe++-- Compact sets for membership tests of local variables.++type LRegSet = IntSet.IntSet++emptyLRegSet :: LRegSet+emptyLRegSet = IntSet.empty++nullLRegSet :: LRegSet -> Bool+nullLRegSet = IntSet.null++insertLRegSet :: LocalReg -> LRegSet -> LRegSet+insertLRegSet l = IntSet.insert (getKey (getUnique l))++elemLRegSet :: LocalReg -> LRegSet -> Bool+elemLRegSet l = IntSet.member (getKey (getUnique l))++-- -----------------------------------------------------------------------------+-- Sinking and inlining++-- This is an optimisation pass that+--  (a) moves assignments closer to their uses, to reduce register pressure+--  (b) pushes assignments into a single branch of a conditional if possible+--  (c) inlines assignments to registers that are mentioned only once+--  (d) discards dead assignments+--+-- This tightens up lots of register-heavy code.  It is particularly+-- helpful in the Cmm generated by the Stg->Cmm code generator, in+-- which every function starts with a copyIn sequence like:+--+--    x1 = R1+--    x2 = Sp[8]+--    x3 = Sp[16]+--    if (Sp - 32 < SpLim) then L1 else L2+--+-- we really want to push the x1..x3 assignments into the L2 branch.+--+-- Algorithm:+--+--  * Start by doing liveness analysis.+--+--  * Keep a list of assignments A; earlier ones may refer to later ones.+--    Currently we only sink assignments to local registers, because we don't+--    have liveness information about global registers.+--+--  * Walk forwards through the graph, look at each node N:+--+--    * If it is a dead assignment, i.e. assignment to a register that is+--      not used after N, discard it.+--+--    * Try to inline based on current list of assignments+--      * If any assignments in A (1) occur only once in N, and (2) are+--        not live after N, inline the assignment and remove it+--        from A.+--+--      * If an assignment in A is cheap (RHS is local register), then+--        inline the assignment and keep it in A in case it is used afterwards.+--+--      * Otherwise don't inline.+--+--    * If N is assignment to a local register pick up the assignment+--      and add it to A.+--+--    * If N is not an assignment to a local register:+--      * remove any assignments from A that conflict with N, and+--        place them before N in the current block.  We call this+--        "dropping" the assignments.+--+--      * An assignment conflicts with N if it:+--        - assigns to a register mentioned in N+--        - mentions a register assigned by N+--        - reads from memory written by N+--      * do this recursively, dropping dependent assignments+--+--    * At an exit node:+--      * drop any assignments that are live on more than one successor+--        and are not trivial+--      * if any successor has more than one predecessor (a join-point),+--        drop everything live in that successor. Since we only propagate+--        assignments that are not dead at the successor, we will therefore+--        eliminate all assignments dead at this point. Thus analysis of a+--        join-point will always begin with an empty list of assignments.+--+--+-- As a result of above algorithm, sinking deletes some dead assignments+-- (transitively, even).  This isn't as good as removeDeadAssignments,+-- but it's much cheaper.++-- -----------------------------------------------------------------------------+-- things that we aren't optimising very well yet.+--+-- -----------+-- (1) From GHC's FastString.hashStr:+--+--  s2ay:+--      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;+--  c2gn:+--      R1 = _s2au::I64;+--      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;+--  c2gp:+--      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,+--                                 4091);+--      _s2an::I64 = _s2an::I64 + 1;+--      _s2au::I64 = _s2cO::I64;+--      goto s2ay;+--+-- a nice loop, but we didn't eliminate the silly assignment at the end.+-- See Note [dependent assignments], which would probably fix this.+-- This is #8336.+--+-- -----------+-- (2) From stg_atomically_frame in PrimOps.cmm+--+-- We have a diamond control flow:+--+--     x = ...+--       |+--      / \+--     A   B+--      \ /+--       |+--    use of x+--+-- Now x won't be sunk down to its use, because we won't push it into+-- both branches of the conditional.  We certainly do have to check+-- that we can sink it past all the code in both A and B, but having+-- discovered that, we could sink it to its use.+--++-- -----------------------------------------------------------------------------++type Assignment = (LocalReg, CmmExpr, AbsMem)+  -- Assignment caches AbsMem, an abstraction of the memory read by+  -- the RHS of the assignment.++type Assignments = [Assignment]+  -- A sequence of assignments; kept in *reverse* order+  -- So the list [ x=e1, y=e2 ] means the sequence of assignments+  --     y = e2+  --     x = e1++cmmSink :: DynFlags -> CmmGraph -> CmmGraph+cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks+  where+  liveness = cmmLocalLiveness dflags graph+  getLive l = mapFindWithDefault Set.empty l liveness++  blocks = revPostorder graph++  join_pts = findJoinPoints blocks++  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]+  sink _ [] = []+  sink sunk (b:bs) =+    -- pprTrace "sink" (ppr lbl) $+    blockJoin first final_middle final_last : sink sunk' bs+    where+      lbl = entryLabel b+      (first, middle, last) = blockSplit b++      succs = successors last++      -- Annotate the middle nodes with the registers live *after*+      -- the node.  This will help us decide whether we can inline+      -- an assignment in the current node or not.+      live = Set.unions (map getLive succs)+      live_middle = gen_kill dflags last live+      ann_middles = annotate dflags live_middle (blockToList middle)++      -- Now sink and inline in this block+      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)+      fold_last = constantFoldNode dflags last+      (final_last, assigs') = tryToInline dflags live fold_last assigs++      -- We cannot sink into join points (successors with more than+      -- one predecessor), so identify the join points and the set+      -- of registers live in them.+      (joins, nonjoins) = partition (`mapMember` join_pts) succs+      live_in_joins = Set.unions (map getLive joins)++      -- We do not want to sink an assignment into multiple branches,+      -- so identify the set of registers live in multiple successors.+      -- This is made more complicated because when we sink an assignment+      -- into one branch, this might change the set of registers that are+      -- now live in multiple branches.+      init_live_sets = map getLive nonjoins+      live_in_multi live_sets r =+         case filter (Set.member r) live_sets of+           (_one:_two:_) -> True+           _ -> False++      -- Now, drop any assignments that we will not sink any further.+      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'++      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')+          where+            should_drop =  conflicts dflags a final_last+                        || not (isTrivial dflags rhs) && live_in_multi live_sets r+                        || r `Set.member` live_in_joins++            live_sets' | should_drop = live_sets+                       | otherwise   = map upd live_sets++            upd set | r `Set.member` set = set `Set.union` live_rhs+                    | otherwise          = set++            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs++      final_middle = foldl' blockSnoc middle' dropped_last++      sunk' = mapUnion sunk $+                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')+                             | l <- succs ]++{- TODO: enable this later, when we have some good tests in place to+   measure the effect and tune it.++-- small: an expression we don't mind duplicating+isSmall :: CmmExpr -> Bool+isSmall (CmmReg (CmmLocal _)) = True  --+isSmall (CmmLit _) = True+isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y+isSmall (CmmRegOff (CmmLocal _) _) = True+isSmall _ = False+-}++--+-- We allow duplication of trivial expressions: registers (both local and+-- global) and literals.+--+isTrivial :: DynFlags -> CmmExpr -> Bool+isTrivial _ (CmmReg (CmmLocal _)) = True+isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]+  if isARM (platformArch (targetPlatform dflags))+  then True -- CodeGen.Platform.ARM does not have globalRegMaybe+  else isJust (globalRegMaybe (targetPlatform dflags) r)+  -- GlobalRegs that are loads from BaseReg are not trivial+isTrivial _ (CmmLit _) = True+isTrivial _ _          = False++--+-- annotate each node with the set of registers live *after* the node+--+annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]+annotate dflags live nodes = snd $ foldr ann (live,[]) nodes+  where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)++--+-- Find the blocks that have multiple successors (join points)+--+findJoinPoints :: [CmmBlock] -> LabelMap Int+findJoinPoints blocks = mapFilter (>1) succ_counts+ where+  all_succs = concatMap successors blocks++  succ_counts :: LabelMap Int+  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs++--+-- filter the list of assignments to remove any assignments that+-- are not live in a continuation.+--+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments+filterAssignments dflags live assigs = reverse (go assigs [])+  where go []             kept = kept+        go (a@(r,_,_):as) kept | needed    = go as (a:kept)+                               | otherwise = go as kept+           where+              needed = r `Set.member` live+                       || any (conflicts dflags a) (map toNode kept)+                       --  Note that we must keep assignments that are+                       -- referred to by other assignments we have+                       -- already kept.++-- -----------------------------------------------------------------------------+-- Walk through the nodes of a block, sinking and inlining assignments+-- as we go.+--+-- On input we pass in a:+--    * list of nodes in the block+--    * a list of assignments that appeared *before* this block and+--      that are being sunk.+--+-- On output we get:+--    * a new block+--    * a list of assignments that will be placed *after* that block.+--++walk :: DynFlags+     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with+                                        -- the set of registers live *after*+                                        -- this node.++     -> Assignments                     -- The current list of+                                        -- assignments we are sinking.+                                        -- Earlier assignments may refer+                                        -- to later ones.++     -> ( Block CmmNode O O             -- The new block+        , Assignments                   -- Assignments to sink further+        )++walk dflags nodes assigs = go nodes emptyBlock assigs+ where+   go []               block as = (block, as)+   go ((live,node):ns) block as+    | shouldDiscard node live           = go ns block as+       -- discard dead assignment+    | Just a <- shouldSink dflags node2 = go ns block (a : as1)+    | otherwise                         = go ns block' as'+    where+      node1 = constantFoldNode dflags node++      (node2, as1) = tryToInline dflags live node1 as++      (dropped, as') = dropAssignmentsSimple dflags+                          (\a -> conflicts dflags a node2) as1++      block' = foldl' blockSnoc block dropped `blockSnoc` node2+++--+-- Heuristic to decide whether to pick up and sink an assignment+-- Currently we pick up all assignments to local registers.  It might+-- be profitable to sink assignments to global regs too, but the+-- liveness analysis doesn't track those (yet) so we can't.+--+shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment+shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)+  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e+shouldSink _ _other = Nothing++--+-- discard dead assignments.  This doesn't do as good a job as+-- removeDeadAssignments, because it would need multiple passes+-- to get all the dead code, but it catches the common case of+-- superfluous reloads from the stack that the stack allocator+-- leaves behind.+--+-- Also we catch "r = r" here.  You might think it would fall+-- out of inlining, but the inliner will see that r is live+-- after the instruction and choose not to inline r in the rhs.+--+shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool+shouldDiscard node live+   = case node of+       CmmAssign r (CmmReg r') | r == r' -> True+       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)+       _otherwise -> False+++toNode :: Assignment -> CmmNode O O+toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs++dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments+                      -> ([CmmNode O O], Assignments)+dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()++dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments+                -> ([CmmNode O O], Assignments)+dropAssignments dflags should_drop state assigs+ = (dropped, reverse kept)+ where+   (dropped,kept) = go state assigs [] []++   go _ []             dropped kept = (dropped, kept)+   go state (assig : rest) dropped kept+      | conflict  = go state' rest (toNode assig : dropped) kept+      | otherwise = go state' rest dropped (assig:kept)+      where+        (dropit, state') = should_drop assig state+        conflict = dropit || any (conflicts dflags assig) dropped+++-- -----------------------------------------------------------------------------+-- Try to inline assignments into a node.+-- This also does constant folding for primpops, since+-- inlining opens up opportunities for doing so.++tryToInline+   :: DynFlags+   -> LocalRegSet               -- set of registers live after this+                                -- node.  We cannot inline anything+                                -- that is live after the node, unless+                                -- it is small enough to duplicate.+   -> CmmNode O x               -- The node to inline into+   -> Assignments               -- Assignments to inline+   -> (+        CmmNode O x             -- New node+      , Assignments             -- Remaining assignments+      )++tryToInline dflags live node assigs = go usages node emptyLRegSet assigs+ where+  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used+  usages = foldLocalRegsUsed dflags addUsage emptyUFM node++  go _usages node _skipped [] = (node, [])++  go usages node skipped (a@(l,rhs,_) : rest)+   | cannot_inline           = dont_inline+   | occurs_none             = discard  -- Note [discard during inlining]+   | occurs_once             = inline_and_discard+   | isTrivial dflags rhs    = inline_and_keep+   | otherwise               = dont_inline+   where+        inline_and_discard = go usages' inl_node skipped rest+          where usages' = foldLocalRegsUsed dflags addUsage usages rhs++        discard = go usages node skipped rest++        dont_inline        = keep node  -- don't inline the assignment, keep it+        inline_and_keep    = keep inl_node -- inline the assignment, keep it++        keep node' = (final_node, a : rest')+          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest+                usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)+                                            usages rhs+                -- we must not inline anything that is mentioned in the RHS+                -- of a binding that we have already skipped, so we set the+                -- usages of the regs on the RHS to 2.++        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]+                        || l `elemLRegSet` skipped+                        || not (okToInline dflags rhs node)++        l_usages = lookupUFM usages l+        l_live   = l `elemRegSet` live++        occurs_once = not l_live && l_usages == Just 1+        occurs_none = not l_live && l_usages == Nothing++        inl_node = improveConditional (mapExpDeep inl_exp node)++        inl_exp :: CmmExpr -> CmmExpr+        -- inl_exp is where the inlining actually takes place!+        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs+        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'+                    = cmmOffset dflags rhs off+                    -- re-constant fold after inlining+        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args+        inl_exp other = other+++{- Note [improveConditional]++cmmMachOpFold tries to simplify conditionals to turn things like+  (a == b) != 1+into+  (a != b)+but there's one case it can't handle: when the comparison is over+floating-point values, we can't invert it, because floating-point+comparisons aren't invertible (because of NaNs).++But we *can* optimise this conditional by swapping the true and false+branches. Given+  CmmCondBranch ((a >## b) != 1) t f+we can turn it into+  CmmCondBranch (a >## b) f t++So here we catch conditionals that weren't optimised by cmmMachOpFold,+and apply above transformation to eliminate the comparison against 1.++It's tempting to just turn every != into == and then let cmmMachOpFold+do its thing, but that risks changing a nice fall-through conditional+into one that requires two jumps. (see swapcond_last in+GHC.Cmm.ContFlowOpt), so instead we carefully look for just the cases where+we can eliminate a comparison.+-}+improveConditional :: CmmNode O x -> CmmNode O x+improveConditional+  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)+  | neLike mop, isComparisonExpr x+  = CmmCondBranch x f t (fmap not l)+  where+    neLike (MO_Ne _) = True+    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1+    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1+    neLike _ = False+improveConditional other = other++-- Note [dependent assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If our assignment list looks like+--+--    [ y = e,  x = ... y ... ]+--+-- We cannot inline x.  Remember this list is really in reverse order,+-- so it means  x = ... y ...; y = e+--+-- Hence if we inline x, the outer assignment to y will capture the+-- reference in x's right hand side.+--+-- In this case we should rename the y in x's right-hand side,+-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]+-- Now we can go ahead and inline x.+--+-- For now we do nothing, because this would require putting+-- everything inside UniqSM.+--+-- One more variant of this (#7366):+--+--   [ y = e, y = z ]+--+-- If we don't want to inline y = e, because y is used many times, we+-- might still be tempted to inline y = z (because we always inline+-- trivial rhs's).  But of course we can't, because y is equal to e,+-- not z.++-- Note [discard during inlining]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Opportunities to discard assignments sometimes appear after we've+-- done some inlining.  Here's an example:+--+--      x = R1;+--      y = P64[x + 7];+--      z = P64[x + 15];+--      /* z is dead */+--      R1 = y & (-8);+--+-- The x assignment is trivial, so we inline it in the RHS of y, and+-- keep both x and y.  z gets dropped because it is dead, then we+-- inline y, and we have a dead assignment to x.  If we don't notice+-- that x is dead in tryToInline, we end up retaining it.++addUsage :: UniqFM Int -> LocalReg -> UniqFM Int+addUsage m r = addToUFM_C (+) m r 1++regsUsedIn :: LRegSet -> CmmExpr -> Bool+regsUsedIn ls _ | nullLRegSet ls = False+regsUsedIn ls e = wrapRecExpf f e False+  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True+        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True+        f _ z = z++-- we don't inline into CmmUnsafeForeignCall if the expression refers+-- to global registers.  This is a HACK to avoid global registers+-- clashing with C argument-passing registers, really the back-end+-- ought to be able to handle it properly, but currently neither PprC+-- nor the NCG can do it.  See Note [Register parameter passing]+-- See also GHC.StgToCmm.Foreign.load_args_into_temps.+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+okToInline dflags expr node@(CmmUnsafeForeignCall{}) =+    not (globalRegistersConflict dflags expr node)+okToInline _ _ _ = True++-- -----------------------------------------------------------------------------++-- | @conflicts (r,e) node@ is @False@ if and only if the assignment+-- @r = e@ can be safely commuted past statement @node@.+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool+conflicts dflags (r, rhs, addr) node++  -- (1) node defines registers used by rhs of assignment. This catches+  -- assignments and all three kinds of calls. See Note [Sinking and calls]+  | globalRegistersConflict dflags rhs node                       = True+  | localRegistersConflict  dflags rhs node                       = True++  -- (2) node uses register defined by assignment+  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True++  -- (3) a store to an address conflicts with a read of the same memory+  | CmmStore addr' e <- node+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True++  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively+  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True+  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True+  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True++  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]+  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True++  -- (6) native calls clobber any memory+  | CmmCall{} <- node, memConflicts addr AnyMem                   = True++  -- (7) otherwise, no conflict+  | otherwise = False++-- Returns True if node defines any global registers that are used in the+-- Cmm expression+globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+globalRegistersConflict dflags expr node =+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)+                 False node++-- Returns True if node defines any local registers that are used in the+-- Cmm expression+localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+localRegistersConflict dflags expr node =+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)+                 False node++-- Note [Sinking and calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)+-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after+-- stack layout (see Note [Sinking after stack layout]) which leads to two+-- invariants related to calls:+--+--   a) during stack layout phase all safe foreign calls are turned into+--      unsafe foreign calls (see Note [Lower safe foreign calls]). This+--      means that we will never encounter CmmForeignCall node when running+--      sinking after stack layout+--+--   b) stack layout saves all variables live across a call on the stack+--      just before making a call (remember we are not sinking assignments to+--      stack):+--+--       L1:+--          x = R1+--          P64[Sp - 16] = L2+--          P64[Sp - 8]  = x+--          Sp = Sp - 16+--          call f() returns L2+--       L2:+--+--      We will attempt to sink { x = R1 } but we will detect conflict with+--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even+--      checking whether it conflicts with { call f() }. In this way we will+--      never need to check any assignment conflicts with CmmCall. Remember+--      that we still need to check for potential memory conflicts.+--+-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes+-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).+-- This assumption holds only when we do sinking after stack layout. If we run+-- it before stack layout we need to check for possible conflicts with all three+-- kinds of calls. Our `conflicts` function does that by using a generic+-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and+-- UserOfRegs typeclasses.+--++-- An abstraction of memory read or written.+data AbsMem+  = NoMem            -- no memory accessed+  | AnyMem           -- arbitrary memory+  | HeapMem          -- definitely heap memory+  | StackMem         -- definitely stack memory+  | SpMem            -- <size>[Sp+n]+       {-# UNPACK #-} !Int+       {-# UNPACK #-} !Int++-- Having SpMem is important because it lets us float loads from Sp+-- past stores to Sp as long as they don't overlap, and this helps to+-- unravel some long sequences of+--    x1 = [Sp + 8]+--    x2 = [Sp + 16]+--    ...+--    [Sp + 8]  = xi+--    [Sp + 16] = xj+--+-- Note that SpMem is invalidated if Sp is changed, but the definition+-- of 'conflicts' above handles that.++-- ToDo: this won't currently fix the following commonly occurring code:+--    x1 = [R1 + 8]+--    x2 = [R1 + 16]+--    ..+--    [Hp - 8] = x1+--    [Hp - 16] = x2+--    ..++-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that+-- assignments to [Hp + n] do not conflict with any other heap memory,+-- but this is tricky to nail down.  What if we had+--+--   x = Hp + n+--   [x] = ...+--+--  the store to [x] should be "new heap", not "old heap".+--  Furthermore, you could imagine that if we started inlining+--  functions in Cmm then there might well be reads of heap memory+--  that was written in the same basic block.  To take advantage of+--  non-aliasing of heap memory we will have to be more clever.++-- Note [Foreign calls clobber heap]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- It is tempting to say that foreign calls clobber only+-- non-heap/stack memory, but unfortunately we break this invariant in+-- the RTS.  For example, in stg_catch_retry_frame we call+-- stmCommitNestedTransaction() which modifies the contents of the+-- TRec it is passed (this actually caused incorrect code to be+-- generated).+--+-- Since the invariant is true for the majority of foreign calls,+-- perhaps we ought to have a special annotation for calls that can+-- modify heap/stack memory.  For now we just use the conservative+-- definition here.+--+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and+-- therefore we should never float any memory operations across one of+-- these calls.+++bothMems :: AbsMem -> AbsMem -> AbsMem+bothMems NoMem    x         = x+bothMems x        NoMem     = x+bothMems HeapMem  HeapMem   = HeapMem+bothMems StackMem StackMem     = StackMem+bothMems (SpMem o1 w1) (SpMem o2 w2)+  | o1 == o2  = SpMem o1 (max w1 w2)+  | otherwise = StackMem+bothMems SpMem{}  StackMem  = StackMem+bothMems StackMem SpMem{}   = StackMem+bothMems _         _        = AnyMem++memConflicts :: AbsMem -> AbsMem -> Bool+memConflicts NoMem      _          = False+memConflicts _          NoMem      = False+memConflicts HeapMem    StackMem   = False+memConflicts StackMem   HeapMem    = False+memConflicts SpMem{}    HeapMem    = False+memConflicts HeapMem    SpMem{}    = False+memConflicts (SpMem o1 w1) (SpMem o2 w2)+  | o1 < o2   = o1 + w1 > o2+  | otherwise = o2 + w2 > o1+memConflicts _         _         = True++exprMem :: DynFlags -> CmmExpr -> AbsMem+exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)+exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)+exprMem _      _                 = NoMem++loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem+loadAddr dflags e w =+  case e of+   CmmReg r       -> regAddr dflags r 0 w+   CmmRegOff r i  -> regAddr dflags r i w+   _other | regUsedIn dflags spReg e -> StackMem+          | otherwise -> AnyMem++regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem+regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)+regAddr _      (CmmGlobal Hp) _ _ = HeapMem+regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself+regAddr _      _ _ _ = AnyMem++{-+Note [Inline GlobalRegs?]++Should we freely inline GlobalRegs?++Actually it doesn't make a huge amount of difference either way, so we+*do* currently treat GlobalRegs as "trivial" and inline them+everywhere, but for what it's worth, here is what I discovered when I+(SimonM) looked into this:++Common sense says we should not inline GlobalRegs, because when we+have++  x = R1++the register allocator will coalesce this assignment, generating no+code, and simply record the fact that x is bound to $rbx (or+whatever).  Furthermore, if we were to sink this assignment, then the+range of code over which R1 is live increases, and the range of code+over which x is live decreases.  All things being equal, it is better+for x to be live than R1, because R1 is a fixed register whereas x can+live in any register.  So we should neither sink nor inline 'x = R1'.++However, not inlining GlobalRegs can have surprising+consequences. e.g. (cgrun020)++  c3EN:+      _s3DB::P64 = R1;+      _c3ES::P64 = _s3DB::P64 & 7;+      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      _s3DD::P64 = P64[_s3DB::P64 + 6];+      _s3DE::P64 = P64[_s3DB::P64 + 14];+      I64[Sp - 8] = c3F0;+      R1 = _s3DE::P64;+      P64[Sp] = _s3DD::P64;++inlining the GlobalReg gives:++  c3EN:+      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      I64[Sp - 8] = c3F0;+      _s3DD::P64 = P64[R1 + 6];+      R1 = P64[R1 + 14];+      P64[Sp] = _s3DD::P64;++but if we don't inline the GlobalReg, instead we get:++      _s3DB::P64 = R1;+      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      I64[Sp - 8] = c3F0;+      R1 = P64[_s3DB::P64 + 14];+      P64[Sp] = P64[_s3DB::P64 + 6];++This looks better - we managed to inline _s3DD - but in fact it+generates an extra reg-reg move:++.Lc3EU:+        movq $c3F0_info,-8(%rbp)+        movq %rbx,%rax+        movq 14(%rbx),%rbx+        movq 6(%rax),%rax+        movq %rax,(%rbp)++because _s3DB is now live across the R1 assignment, we lost the+benefit of coalescing.++Who is at fault here?  Perhaps if we knew that _s3DB was an alias for+R1, then we would not sink a reference to _s3DB past the R1+assignment.  Or perhaps we *should* do that - we might gain by sinking+it, despite losing the coalescing opportunity.++Sometimes not inlining global registers wins by virtue of the rule+about not inlining into arguments of a foreign call, e.g. (T7163) this+is what happens when we inlined F1:++      _s3L2::F32 = F1;+      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);++but if we don't inline F1:++      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,+                                                                                            10.0 :: W32));+-}
+ compiler/GHC/Cmm/Switch/Implement.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE GADTs #-}+module GHC.Cmm.Switch.Implement+  ( cmmImplementSwitchPlans+  )+where++import GhcPrelude++import GHC.Cmm.Dataflow.Block+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import UniqSupply+import DynFlags++--+-- This module replaces Switch statements as generated by the Stg -> Cmm+-- transformation, which might be huge and sparse and hence unsuitable for+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).+--+-- The actual, abstract strategy is determined by createSwitchPlan in+-- GHC.Cmm.Switch and returned as a SwitchPlan; here is just the implementation in+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch.+--+-- This division into different modules is both to clearly separate concerns,+-- but also because createSwitchPlan needs access to the constructors of+-- SwitchTargets, a data type exported abstractly by GHC.Cmm.Switch.+--++-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for+-- code generation.+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans dflags g+    -- Switch generation done by backend (LLVM/C)+    | targetSupportsSwitch (hscTarget dflags) = return g+    | otherwise = do+    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)+    return $ ofBlockList (g_entry g) blocks'++visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]+visitSwitches dflags block+  | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block+  = do+    let plan = createSwitchPlan ids+    -- See Note [Floating switch expressions]+    (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr++    (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan++    let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail++    return $ block' : newBlocks++  | otherwise+  = return [block]++-- Note [Floating switch expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- When we translate a sparse switch into a search tree we would like+-- to compute the value we compare against only once.++-- For this purpose we assign the switch expression to a local register+-- and then use this register when constructing the actual binary tree.++-- This is important as the expression could contain expensive code like+-- memory loads or divisions which we REALLY don't want to duplicate.++-- This happened in parts of the handwritten RTS Cmm code. See also #16933++-- See Note [Floating switch expressions]+floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr _      reg@(CmmReg {})  = return (emptyBlock, reg)+floatSwitchExpr dflags expr             = do+  (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM+  return (BMiddle assign, expr')+++-- Implementing a switch plan (returning a tail block)+implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])+implementSwitchPlan dflags scope expr = go+  where+    go (Unconditionally l)+      = return (emptyBlock `blockJoinTail` CmmBranch l, [])+    go (JumpTable ids)+      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])+    go (IfLT signed i ids1 ids2)+      = do+        (bid1, newBlocks1) <- go' ids1+        (bid2, newBlocks2) <- go' ids2++        let lt | signed    = cmmSLtWord+               | otherwise = cmmULtWord+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i+            lastNode = CmmCondBranch scrut bid1 bid2 Nothing+            lastBlock = emptyBlock `blockJoinTail` lastNode+        return (lastBlock, newBlocks1++newBlocks2)+    go (IfEqual i l ids2)+      = do+        (bid2, newBlocks2) <- go' ids2++        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i+            lastNode = CmmCondBranch scrut bid2 l Nothing+            lastBlock = emptyBlock `blockJoinTail` lastNode+        return (lastBlock, newBlocks2)++    -- Same but returning a label to branch to+    go' (Unconditionally l)+      = return (l, [])+    go' p+      = do+        bid <- mkBlockId `fmap` getUniqueM+        (last, newBlocks) <- go p+        let block = CmmEntry bid scope `blockJoinHead` last+        return (bid, block: newBlocks)
+ compiler/GHC/Cmm/Utils.hs view
@@ -0,0 +1,609 @@+{-# LANGUAGE GADTs, RankNTypes #-}+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- Cmm utilities.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.Cmm.Utils(+        -- CmmType+        primRepCmmType, slotCmmType, slotForeignHint,+        typeCmmType, typeForeignHint, primRepForeignHint,++        -- CmmLit+        zeroCLit, mkIntCLit,+        mkWordCLit, packHalfWordsCLit,+        mkByteStringCLit,+        mkDataLits, mkRODataLits,+        mkStgWordCLit,++        -- CmmExpr+        mkIntExpr, zeroExpr,+        mkLblExpr,+        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,+        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,+        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,+        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,+        cmmNegate,+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+        cmmSLtWord,+        cmmNeWord, cmmEqWord,+        cmmOrWord, cmmAndWord,+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,+        cmmToWord,++        cmmMkAssign,++        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,++        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,+        currentTSOExpr, currentNurseryExpr, cccsExpr,++        -- Statics+        blankWord,++        -- Tagging+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,+        cmmConstrTag1,++        -- Overlap and usage+        regsOverlap, regUsedIn,++        -- Liveness and bitmaps+        mkLiveness,++        -- * Operations that probably don't belong here+        modifyGraph,++        ofBlockMap, toBlockMap,+        ofBlockList, toBlockList, bodyToBlockList,+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,+        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,++        -- * Ticks+        blockTicks+  ) where++import GhcPrelude++import TyCon    ( PrimRep(..), PrimElemRep(..) )+import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )++import GHC.Runtime.Layout+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import Outputable+import DynFlags+import Unique+import GHC.Platform.Regs++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Bits+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections++---------------------------------------------------+--+--      CmmTypes+--+---------------------------------------------------++primRepCmmType :: DynFlags -> PrimRep -> CmmType+primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"+primRepCmmType dflags LiftedRep        = gcWord dflags+primRepCmmType dflags UnliftedRep      = gcWord dflags+primRepCmmType dflags IntRep           = bWord dflags+primRepCmmType dflags WordRep          = bWord dflags+primRepCmmType _      Int8Rep          = b8+primRepCmmType _      Word8Rep         = b8+primRepCmmType _      Int16Rep         = b16+primRepCmmType _      Word16Rep        = b16+primRepCmmType _      Int32Rep         = b32+primRepCmmType _      Word32Rep        = b32+primRepCmmType _      Int64Rep         = b64+primRepCmmType _      Word64Rep        = b64+primRepCmmType dflags AddrRep          = bWord dflags+primRepCmmType _      FloatRep         = f32+primRepCmmType _      DoubleRep        = f64+primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)++slotCmmType :: DynFlags -> SlotTy -> CmmType+slotCmmType dflags PtrSlot    = gcWord dflags+slotCmmType dflags WordSlot   = bWord dflags+slotCmmType _      Word64Slot = b64+slotCmmType _      FloatSlot  = f32+slotCmmType _      DoubleSlot = f64++primElemRepCmmType :: PrimElemRep -> CmmType+primElemRepCmmType Int8ElemRep   = b8+primElemRepCmmType Int16ElemRep  = b16+primElemRepCmmType Int32ElemRep  = b32+primElemRepCmmType Int64ElemRep  = b64+primElemRepCmmType Word8ElemRep  = b8+primElemRepCmmType Word16ElemRep = b16+primElemRepCmmType Word32ElemRep = b32+primElemRepCmmType Word64ElemRep = b64+primElemRepCmmType FloatElemRep  = f32+primElemRepCmmType DoubleElemRep = f64++typeCmmType :: DynFlags -> UnaryType -> CmmType+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)++primRepForeignHint :: PrimRep -> ForeignHint+primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"+primRepForeignHint LiftedRep    = AddrHint+primRepForeignHint UnliftedRep  = AddrHint+primRepForeignHint IntRep       = SignedHint+primRepForeignHint Int8Rep      = SignedHint+primRepForeignHint Int16Rep     = SignedHint+primRepForeignHint Int32Rep     = SignedHint+primRepForeignHint Int64Rep     = SignedHint+primRepForeignHint WordRep      = NoHint+primRepForeignHint Word8Rep     = NoHint+primRepForeignHint Word16Rep    = NoHint+primRepForeignHint Word32Rep    = NoHint+primRepForeignHint Word64Rep    = NoHint+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg+primRepForeignHint FloatRep     = NoHint+primRepForeignHint DoubleRep    = NoHint+primRepForeignHint (VecRep {})  = NoHint++slotForeignHint :: SlotTy -> ForeignHint+slotForeignHint PtrSlot       = AddrHint+slotForeignHint WordSlot      = NoHint+slotForeignHint Word64Slot    = NoHint+slotForeignHint FloatSlot     = NoHint+slotForeignHint DoubleSlot    = NoHint++typeForeignHint :: UnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRep1++---------------------------------------------------+--+--      CmmLit+--+---------------------------------------------------++-- XXX: should really be Integer, since Int doesn't necessarily cover+-- the full range of target Ints.+mkIntCLit :: DynFlags -> Int -> CmmLit+mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)++mkIntExpr :: DynFlags -> Int -> CmmExpr+mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i++zeroCLit :: DynFlags -> CmmLit+zeroCLit dflags = CmmInt 0 (wordWidth dflags)++zeroExpr :: DynFlags -> CmmExpr+zeroExpr dflags = CmmLit (zeroCLit dflags)++mkWordCLit :: DynFlags -> Integer -> CmmLit+mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)++mkByteStringCLit+  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)+-- We have to make a top-level decl for the string,+-- and return a literal pointing to it+mkByteStringCLit lbl bytes+  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])+  where+    -- This can not happen for String literals (as there \NUL is replaced by+    -- C0 80). However, it can happen with Addr# literals.+    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString++mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a data-segment data block+mkDataLits section lbl lits+  = CmmData section (Statics lbl $ map CmmStaticLit lits)++mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a read-only data block+mkRODataLits lbl lits+  = mkDataLits section lbl lits+  where+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl+            | otherwise                = Section ReadOnlyData lbl+    needsRelocation (CmmLabel _)      = True+    needsRelocation (CmmLabelOff _ _) = True+    needsRelocation _                 = False++mkStgWordCLit :: DynFlags -> StgWord -> CmmLit+mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)++packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit+-- Make a single word literal in which the lower_half_word is+-- at the lower address, and the upper_half_word is at the+-- higher address+-- ToDo: consider using half-word lits instead+--       but be careful: that's vulnerable when reversed+packHalfWordsCLit dflags lower_half_word upper_half_word+   = if wORDS_BIGENDIAN dflags+     then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)+     else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))+    where l = fromStgHalfWord lower_half_word+          u = fromStgHalfWord upper_half_word++---------------------------------------------------+--+--      CmmExpr+--+---------------------------------------------------++mkLblExpr :: CLabel -> CmmExpr+mkLblExpr lbl = CmmLit (CmmLabel lbl)++cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+-- assumes base and offset have the same CmmType+cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)+cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]++cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr+cmmOffset _ e                 0        = e+cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off+cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)+cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)+cmmOffset _ (CmmStackSlot area off) byte_off+  = CmmStackSlot area (off - byte_off)+  -- note stack area offsets increase towards lower addresses+cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2+  = CmmMachOp (MO_Add rep)+              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]+cmmOffset dflags expr byte_off+  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]+  where+    width = cmmExprWidth dflags expr++-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.+cmmRegOff :: CmmReg -> Int -> CmmExpr+cmmRegOff reg 0        = CmmReg reg+cmmRegOff reg byte_off = CmmRegOff reg byte_off++cmmOffsetLit :: CmmLit -> Int -> CmmLit+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)+cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)++cmmLabelOff :: CLabel -> Int -> CmmLit+-- Smart constructor for CmmLabelOff+cmmLabelOff lbl 0        = CmmLabel lbl+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off++-- | Useful for creating an index into an array, with a statically known offset.+-- The type is the element type; used for making the multiplier+cmmIndex :: DynFlags+         -> Width       -- Width w+         -> CmmExpr     -- Address of vector of items of width w+         -> Int         -- Which element of the vector (0 based)+         -> CmmExpr     -- Address of i'th element+cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)++-- | Useful for creating an index into an array, with an unknown offset.+cmmIndexExpr :: DynFlags+             -> Width           -- Width w+             -> CmmExpr         -- Address of vector of items of width w+             -> CmmExpr         -- Which element of the vector (0 based)+             -> CmmExpr         -- Address of i'th element+cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)+cmmIndexExpr dflags width base idx =+  cmmOffsetExpr dflags base byte_off+  where+    idx_w = cmmExprWidth dflags idx+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]++cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr+cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty++-- The "B" variants take byte offsets+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr+cmmRegOffB = cmmRegOff++cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr+cmmOffsetB = cmmOffset++cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExprB = cmmOffsetExpr++cmmLabelOffB :: CLabel -> ByteOff -> CmmLit+cmmLabelOffB = cmmLabelOff++cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit+cmmOffsetLitB = cmmOffsetLit++-----------------------+-- The "W" variants take word offsets++cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+-- The second arg is a *word* offset; need to change it to bytes+cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)+cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off++cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr+cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)++cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr+cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)++cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit+cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)++cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit+cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)++cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr+cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty++-----------------------+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+  cmmSLtWord,+  cmmNeWord, cmmEqWord,+  cmmOrWord, cmmAndWord,+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord+  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]+cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]+cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]+cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]+cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]+cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]+cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]+cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]+cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]+cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]+cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]+cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]+cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]++cmmNegate :: DynFlags -> CmmExpr -> CmmExpr+cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)+cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]++blankWord :: DynFlags -> CmmStatic+blankWord dflags = CmmUninitialised (wORD_SIZE dflags)++cmmToWord :: DynFlags -> CmmExpr -> CmmExpr+cmmToWord dflags e+  | w == word  = e+  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]+  where+    w = cmmExprWidth dflags e+    word = wordWidth dflags++cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)+cmmMkAssign dflags expr uq =+  let !ty = cmmExprType dflags expr+      reg = (CmmLocal (LocalReg uq ty))+  in  (CmmAssign reg expr, CmmReg reg)+++---------------------------------------------------+--+--      CmmExpr predicates+--+---------------------------------------------------++isTrivialCmmExpr :: CmmExpr -> Bool+isTrivialCmmExpr (CmmLoad _ _)      = False+isTrivialCmmExpr (CmmMachOp _ _)    = False+isTrivialCmmExpr (CmmLit _)         = True+isTrivialCmmExpr (CmmReg _)         = True+isTrivialCmmExpr (CmmRegOff _ _)    = True+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"++hasNoGlobalRegs :: CmmExpr -> Bool+hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e+hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es+hasNoGlobalRegs (CmmLit _)                 = True+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True+hasNoGlobalRegs _ = False++isLit :: CmmExpr -> Bool+isLit (CmmLit _) = True+isLit _          = False++isComparisonExpr :: CmmExpr -> Bool+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op+isComparisonExpr _                  = False++---------------------------------------------------+--+--      Tagging+--+---------------------------------------------------++-- Tag bits mask+cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr+cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)+cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))++-- Used to untag a possibly tagged pointer+-- A static label need not be untagged+cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr+cmmUntag _ e@(CmmLit (CmmLabel _)) = e+-- Default case+cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)++-- Test if a closure pointer is untagged+cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)++-- Get constructor tag, but one based.+cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)+++-----------------------------------------------------------------------------+-- Overlap and usage++-- | Returns True if the two STG registers overlap on the specified+-- platform, in the sense that writing to one will clobber the+-- other. This includes the case that the two registers are the same+-- STG register. See Note [Overlapping global registers] for details.+regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool+regsOverlap dflags (CmmGlobal g) (CmmGlobal g')+  | Just real  <- globalRegMaybe (targetPlatform dflags) g,+    Just real' <- globalRegMaybe (targetPlatform dflags) g',+    real == real'+    = True+regsOverlap _ reg reg' = reg == reg'++-- | Returns True if the STG register is used by the expression, in+-- the sense that a store to the register might affect the value of+-- the expression.+--+-- We must check for overlapping registers and not just equal+-- registers here, otherwise CmmSink may incorrectly reorder+-- assignments that conflict due to overlap. See #10521 and Note+-- [Overlapping global registers].+regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool+regUsedIn dflags = regUsedIn_ where+  _   `regUsedIn_` CmmLit _         = False+  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e+  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es+  _   `regUsedIn_` CmmStackSlot _ _ = False++--------------------------------------------+--+--        mkLiveness+--+---------------------------------------------++mkLiveness :: DynFlags -> [LocalReg] -> Liveness+mkLiveness _      [] = []+mkLiveness dflags (reg:regs)+  = bits ++ mkLiveness dflags regs+  where+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)+            `quot` wORD_SIZE dflags+            -- number of words, rounded up+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr++    is_non_ptr = not $ isGcPtrType (localRegType reg)+++-- ============================================== -+-- ============================================== -+-- ============================================== -++---------------------------------------------------+--+--      Manipulating CmmGraphs+--+---------------------------------------------------++modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}++toBlockMap :: CmmGraph -> LabelMap CmmBlock+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body++ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}++toBlockList :: CmmGraph -> [CmmBlock]+toBlockList g = mapElems $ toBlockMap g++-- | like 'toBlockList', but the entry block always comes first+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]+toBlockListEntryFirst g+  | mapNull m  = []+  | otherwise  = entry_block : others+  where+    m = toBlockMap g+    entry_id = g_entry g+    Just entry_block = mapLookup entry_id m+    others = filter ((/= entry_id) . entryLabel) (mapElems m)++-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks+-- so that the false case of a conditional jumps to the next block in the output+-- list of blocks. This matches the way OldCmm blocks were output since in+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches+-- have both true and false successors. Block ordering can make a big difference+-- in performance in the LLVM backend. Note that we rely crucially on the order+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode+-- defined in cmm/CmmNode.hs. -GBM+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]+toBlockListEntryFirstFalseFallthrough g+  | mapNull m  = []+  | otherwise  = dfs setEmpty [entry_block]+  where+    m = toBlockMap g+    entry_id = g_entry g+    Just entry_block = mapLookup entry_id m++    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]+    dfs _ [] = []+    dfs visited (block:bs)+      | id `setMember` visited = dfs visited bs+      | otherwise              = block : dfs (setInsert id visited) bs'+      where id = entryLabel block+            bs' = foldr add_id bs (successors block)+            add_id id bs = case mapLookup id m of+                              Just b  -> b : bs+                              Nothing -> bs++ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph+ofBlockList entry blocks = CmmGraph { g_entry = entry+                                    , g_graph = GMany NothingO body NothingO }+  where body = foldr addBlock emptyBody blocks++bodyToBlockList :: Body CmmNode -> [CmmBlock]+bodyToBlockList body = mapElems body++mapGraphNodes :: ( CmmNode C O -> CmmNode C O+                 , CmmNode O O -> CmmNode O O+                 , CmmNode O C -> CmmNode O C)+              -> CmmGraph -> CmmGraph+mapGraphNodes funs@(mf,_,_) g =+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $+  mapMap (mapBlock3' funs) $ toBlockMap g++mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph+mapGraphNodes1 f = modifyGraph (mapGraph f)+++foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g++revPostorder :: CmmGraph -> [CmmBlock]+revPostorder g = {-# SCC "revPostorder" #-}+    revPostorderFrom (toBlockMap g) (g_entry g)++-------------------------------------------------+-- Tick utilities++-- | Extract all tick annotations from the given block+blockTicks :: Block CmmNode C C -> [CmmTickish]+blockTicks b = reverse $ foldBlockNodesF goStmt b []+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]+        goStmt  (CmmTick t) ts = t:ts+        goStmt  _other      ts = ts+++-- -----------------------------------------------------------------------------+-- Access to common global registers++baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,+  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr+baseExpr = CmmReg baseReg+spExpr = CmmReg spReg+spLimExpr = CmmReg spLimReg+hpExpr = CmmReg hpReg+hpLimExpr = CmmReg hpLimReg+currentTSOExpr = CmmReg currentTSOReg+currentNurseryExpr = CmmReg currentNurseryReg+cccsExpr = CmmReg cccsReg
+ compiler/GHC/CmmToC.hs view
@@ -0,0 +1,1380 @@+{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing of Cmm as C, suitable for feeding gcc+--+-- (c) The University of Glasgow 2004-2006+--+-- Print Cmm as real C, for -fvia-C+--+-- See wiki:commentary/compiler/backends/ppr-c+--+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"+-- relative to the old AbstractC, and many oddities/decorations have+-- disappeared from the data type.+--+-- This code generator is only supported in unregisterised mode.+--+-----------------------------------------------------------------------------++module GHC.CmmToC (+        writeC+  ) where++#include "HsVersions.h"++-- Cmm stuff+import GhcPrelude++import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import ForeignCall+import GHC.Cmm hiding (pprBBlock)+import GHC.Cmm.Ppr () -- For Outputable instances+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Utils+import GHC.Cmm.Switch++-- Utils+import CPrim+import DynFlags+import FastString+import Outputable+import GHC.Platform+import UniqSet+import UniqFM+import Unique+import Util++-- The rest+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Control.Monad.ST+import Data.Bits+import Data.Char+import Data.List+import Data.Map (Map)+import Data.Word+import System.IO+import qualified Data.Map as Map+import Control.Monad (ap)+import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST++-- --------------------------------------------------------------------------+-- Top level++writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()+writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)++-- --------------------------------------------------------------------------+-- Now do some real work+--+-- for fun, we could call cmmToCmm over the tops...+--++pprC :: RawCmmGroup -> SDoc+pprC tops = vcat $ intersperse blankLine $ map pprTop tops++--+-- top level procs+--+pprTop :: RawCmmDecl -> SDoc+pprTop (CmmProc infos clbl _in_live_regs graph) =++    (case mapLookup (g_entry graph) infos of+       Nothing -> empty+       Just (Statics info_clbl info_dat) ->+           pprDataExterns info_dat $$+           pprWordArray info_is_in_rodata info_clbl info_dat) $$+    (vcat [+           blankLine,+           extern_decls,+           (if (externallyVisibleCLabel clbl)+                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,+           nest 8 temp_decls,+           vcat (map pprBBlock blocks),+           rbrace ]+    )+  where+        -- info tables are always in .rodata+        info_is_in_rodata = True+        blocks = toBlockListEntryFirst graph+        (temp_decls, extern_decls) = pprTempAndExternDecls blocks+++-- Chunks of static data.++-- We only handle (a) arrays of word-sized things and (b) strings.++pprTop (CmmData section (Statics lbl [CmmString str])) =+  pprExternDecl lbl $$+  hcat [+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+    text "[] = ", pprStringInCStyle str, semi+  ]++pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =+  pprExternDecl lbl $$+  hcat [+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+    brackets (int size), semi+  ]++pprTop (CmmData section (Statics lbl lits)) =+  pprDataExterns lits $$+  pprWordArray (isSecConstant section) lbl lits++-- --------------------------------------------------------------------------+-- BasicBlocks are self-contained entities: they always end in a jump.+--+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn+-- as many jumps as possible into fall throughs.+--++pprBBlock :: CmmBlock -> SDoc+pprBBlock block =+  nest 4 (pprBlockId (entryLabel block) <> colon) $$+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)+ where+  (_, nodes, last)  = blockSplit block++-- --------------------------------------------------------------------------+-- Info tables. Just arrays of words.+-- See codeGen/ClosureInfo, and nativeGen/PprMach++pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc+pprWordArray is_ro lbl ds+  = sdocWithDynFlags $ \dflags ->+    -- TODO: align closures only+    pprExternDecl lbl $$+    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"+         , space, ppr lbl, text "[]"+         -- See Note [StgWord alignment]+         , pprAlignment (wordWidth dflags)+         , text "= {" ]+    $$ nest 8 (commafy (pprStatics dflags ds))+    $$ text "};"++pprAlignment :: Width -> SDoc+pprAlignment words =+     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"++-- Note [StgWord alignment]+-- C codegen builds static closures as StgWord C arrays (pprWordArray).+-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume+-- pointers to 'StgClosure' are aligned at pointer size boundary:+--  4 byte boundary on 32 systems+--  and 8 bytes on 64-bit systems+-- see TAG_MASK and TAG_BITS definition and usage.+--+-- It's a reasonable assumption also known as natural alignment.+-- Although some architectures have different alignment rules.+-- One of known exceptions is m68k (#11395, comment:16) where:+--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4+--+-- Thus we explicitly increase alignment by using+--    __attribute__((aligned(4)))+-- declaration.++--+-- has to be static, if it isn't globally visible+--+pprLocalness :: CLabel -> SDoc+pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "+                 | otherwise = empty++pprConstness :: Bool -> SDoc+pprConstness is_ro | is_ro = text "const "+                   | otherwise = empty++-- --------------------------------------------------------------------------+-- Statements.+--++pprStmt :: CmmNode e x -> SDoc++pprStmt stmt =+    sdocWithDynFlags $ \dflags ->+    case stmt of+    CmmEntry{}   -> empty+    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")+                          -- XXX if the string contains "*/", we need to fix it+                          -- XXX we probably want to emit these comments when+                          -- some debugging option is on.  They can get quite+                          -- large.++    CmmTick _ -> empty+    CmmUnwind{} -> empty++    CmmAssign dest src -> pprAssign dflags dest src++    CmmStore  dest src+        | typeWidth rep == W64 && wordWidth dflags /= W64+        -> (if isFloatType rep then text "ASSIGN_DBL"+                               else ptext (sLit ("ASSIGN_Word64"))) <>+           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi++        | otherwise+        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]+        where+          rep = cmmExprType dflags src++    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->+        fnCall+        where+        (res_hints, arg_hints) = foreignTargetHints target+        hresults = zip results res_hints+        hargs    = zip args arg_hints++        ForeignConvention cconv _ _ ret = conv++        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)++        -- See wiki:commentary/compiler/backends/ppr-c#prototypes+        fnCall =+            case fn of+              CmmLit (CmmLabel lbl)+                | StdCallConv <- cconv ->+                    pprCall (ppr lbl) cconv hresults hargs+                        -- stdcall functions must be declared with+                        -- a function type, otherwise the C compiler+                        -- doesn't add the @n suffix to the label.  We+                        -- can't add the @n suffix ourselves, because+                        -- it isn't valid C.+                | CmmNeverReturns <- ret ->+                    pprCall cast_fn cconv hresults hargs <> semi+                | not (isMathFun lbl) ->+                    pprForeignCall (ppr lbl) cconv hresults hargs+              _ ->+                    pprCall cast_fn cconv hresults hargs <> semi+                        -- for a dynamic call, no declaration is necessary.++    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty+    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty++    CmmUnsafeForeignCall target@(PrimTarget op) results args ->+        fn_call+      where+        cconv = CCallConv+        fn = pprCallishMachOp_for_C op++        (res_hints, arg_hints) = foreignTargetHints target+        hresults = zip results res_hints+        hargs    = zip args arg_hints++        fn_call+          -- The mem primops carry an extra alignment arg.+          -- We could maybe emit an alignment directive using this info.+          -- We also need to cast mem primops to prevent conflicts with GCC+          -- builtins (see bug #5967).+          | Just _align <- machOpMemcpyishAlign op+          = (text ";EFF_(" <> fn <> char ')' <> semi) $$+            pprForeignCall fn cconv hresults hargs+          | otherwise+          = pprCall fn cconv hresults hargs++    CmmBranch ident          -> pprBranch ident+    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi+    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->+                                pprSwitch dflags arg ids++    _other -> pprPanic "PprC.pprStmt" (ppr stmt)++type Hinted a = (a, ForeignHint)++pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]+               -> SDoc+pprForeignCall fn cconv results args = fn_call+  where+    fn_call = braces (+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi+              $$ pprCall (text "ghcFunPtr") cconv results args <> semi+             )+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)++pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCFunType ppr_fn cconv ress args+  = sdocWithDynFlags $ \dflags ->+    let res_type [] = text "void"+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint+        res_type _ = panic "pprCFunType: only void or 1 return value supported"++        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint+    in res_type ress <+>+       parens (ccallConvAttribute cconv <> ppr_fn) <>+       parens (commafy (map arg_type args))++-- ---------------------------------------------------------------------+-- unconditional branches+pprBranch :: BlockId -> SDoc+pprBranch ident = text "goto" <+> pprBlockId ident <> semi+++-- ---------------------------------------------------------------------+-- conditional branches to local labels+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc+pprCondBranch expr yes no+        = hsep [ text "if" , parens(pprExpr expr) ,+                        text "goto", pprBlockId yes <> semi,+                        text "else goto", pprBlockId no <> semi ]++-- ---------------------------------------------------------------------+-- a local table branch+--+-- we find the fall-through cases+--+pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc+pprSwitch dflags e ids+  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)+                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace+  where+    (pairs, mbdef) = switchTargetsFallThrough ids++    -- fall through case+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix+        where+        do_fallthrough ix =+                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                        text "/* fall through */" ]++        final_branch ix =+                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                       text "goto" , (pprBlockId ident) <> semi ]++    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"++    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi+        | otherwise       = empty++-- ---------------------------------------------------------------------+-- Expressions.+--++-- C Types: the invariant is that the C expression generated by+--+--      pprExpr e+--+-- has a type in C which is also given by+--+--      machRepCType (cmmExprType e)+--+-- (similar invariants apply to the rest of the pretty printer).++pprExpr :: CmmExpr -> SDoc+pprExpr e = case e of+    CmmLit lit -> pprLit lit+++    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty+    CmmReg reg      -> pprCastReg reg+    CmmRegOff reg 0 -> pprCastReg reg++    -- CmmRegOff is an alias of MO_Add+    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->+                       pprCastReg reg <> char '+' <>+                       pprHexVal (fromIntegral i) (wordWidth dflags)++    CmmMachOp mop args -> pprMachOpApp mop args++    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"+++pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc+pprLoad dflags e ty+  | width == W64, wordWidth dflags /= W64+  = (if isFloatType ty then text "PK_DBL"+                       else text "PK_Word64")+    <> parens (mkP_ <> pprExpr1 e)++  | otherwise+  = case e of+        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+                 -> char '*' <> pprAsPtrReg r++        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+                      -> char '*' <> pprAsPtrReg r++        CmmRegOff r off | isPtrReg r && width == wordWidth dflags+                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)+        -- ToDo: check that the offset is a word multiple?+        --       (For tagging to work, I had to avoid unaligned loads. --ARY)+                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))++        _other -> cLoad e ty+  where+    width = typeWidth ty++pprExpr1 :: CmmExpr -> SDoc+pprExpr1 (CmmLit lit)     = pprLit1 lit+pprExpr1 e@(CmmReg _reg)  = pprExpr e+pprExpr1 other            = parens (pprExpr other)++-- --------------------------------------------------------------------------+-- MachOp applications++pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc++pprMachOpApp op args+  | isMulMayOfloOp op+  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))+  where isMulMayOfloOp (MO_U_MulMayOflo _) = True+        isMulMayOfloOp (MO_S_MulMayOflo _) = True+        isMulMayOfloOp _ = False++pprMachOpApp mop args+  | Just ty <- machOpNeedsCast mop+  = ty <> parens (pprMachOpApp' mop args)+  | otherwise+  = pprMachOpApp' mop args++-- Comparisons in C have type 'int', but we want type W_ (this is what+-- resultRepOfMachOp says).  The other C operations inherit their type+-- from their operands, so no casting is required.+machOpNeedsCast :: MachOp -> Maybe SDoc+machOpNeedsCast mop+  | isComparisonMachOp mop = Just mkW_+  | otherwise              = Nothing++pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc+pprMachOpApp' mop args+ = case args of+    -- dyadic+    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y++    -- unary+    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)++    _     -> panic "PprC.pprMachOp : machop with wrong number of args"++  where+        -- Cast needed for signed integer ops+    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->+                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e+             | needsFCasts mop = sdocWithDynFlags $ \dflags ->+                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e+             | otherwise    = pprExpr1 e+    needsFCasts (MO_F_Eq _)   = False+    needsFCasts (MO_F_Ne _)   = False+    needsFCasts (MO_F_Neg _)  = True+    needsFCasts (MO_F_Quot _) = True+    needsFCasts mop  = floatComparison mop++-- --------------------------------------------------------------------------+-- Literals++pprLit :: CmmLit -> SDoc+pprLit lit = case lit of+    CmmInt i rep      -> pprHexVal i rep++    CmmFloat f w       -> parens (machRep_F_CType w) <> str+        where d = fromRational f :: Double+              str | isInfinite d && d < 0 = text "-INFINITY"+                  | isInfinite d          = text "INFINITY"+                  | isNaN d               = text "NAN"+                  | otherwise             = text (show d)+                -- these constants come from <math.h>+                -- see #1861++    CmmVec {} -> panic "PprC printing vector literal"++    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)+    CmmHighStackMark   -> panic "PprC printing high stack mark"+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i+    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C+        -- WARNING:+        --  * the lit must occur in the info table clbl2+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i++    where+        pprCLabelAddr lbl = char '&' <> ppr lbl++pprLit1 :: CmmLit -> SDoc+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)+pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)+pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)+pprLit1 other = pprLit other++-- ---------------------------------------------------------------------------+-- Static data++pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]+pprStatics _ [] = []+pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)+  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'+  -- adjacent floats aren't padded but combined into a single word+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest+  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'+  | wORD_SIZE dflags == 4+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest+  | otherwise+  = pprPanic "pprStatics: float" (vcat (map ppr' rest))+    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->+                                  ppr (cmmLitType dflags l)+          ppr' _other           = text "bad static!"+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)+  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest++pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)+  | wordWidth dflags == W32+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :+                            CmmStaticLit (CmmInt r W32) : rest)+    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :+                            CmmStaticLit (CmmInt q W32) : rest)+  where r = i .&. 0xffffffff+        q = i `shiftR` 32+pprStatics dflags (CmmStaticLit (CmmInt a W32) :+                   CmmStaticLit (CmmInt b W32) : rest)+  | wordWidth dflags == W64+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :+                            rest)+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :+                            rest)+pprStatics dflags (CmmStaticLit (CmmInt a W16) :+                   CmmStaticLit (CmmInt b W16) : rest)+  | wordWidth dflags == W32+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :+                            rest)+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :+                            rest)+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)+  | w /= wordWidth dflags+  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)+pprStatics dflags (CmmStaticLit lit : rest)+  = pprLit1 lit : pprStatics dflags rest+pprStatics _ (other : _)+  = pprPanic "pprStatics: other" (pprStatic other)++pprStatic :: CmmStatic -> SDoc+pprStatic s = case s of++    CmmStaticLit lit   -> nest 4 (pprLit lit)+    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))++    -- these should be inlined, like the old .hc+    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))+++-- ---------------------------------------------------------------------------+-- Block Ids++pprBlockId :: BlockId -> SDoc+pprBlockId b = char '_' <> ppr (getUnique b)++-- --------------------------------------------------------------------------+-- Print a MachOp in a way suitable for emitting via C.+--++pprMachOp_for_C :: MachOp -> SDoc++pprMachOp_for_C mop = case mop of++        -- Integer operations+        MO_Add          _ -> char '+'+        MO_Sub          _ -> char '-'+        MO_Eq           _ -> text "=="+        MO_Ne           _ -> text "!="+        MO_Mul          _ -> char '*'++        MO_S_Quot       _ -> char '/'+        MO_S_Rem        _ -> char '%'+        MO_S_Neg        _ -> char '-'++        MO_U_Quot       _ -> char '/'+        MO_U_Rem        _ -> char '%'++        -- & Floating-point operations+        MO_F_Add        _ -> char '+'+        MO_F_Sub        _ -> char '-'+        MO_F_Neg        _ -> char '-'+        MO_F_Mul        _ -> char '*'+        MO_F_Quot       _ -> char '/'++        -- Signed comparisons+        MO_S_Ge         _ -> text ">="+        MO_S_Le         _ -> text "<="+        MO_S_Gt         _ -> char '>'+        MO_S_Lt         _ -> char '<'++        -- & Unsigned comparisons+        MO_U_Ge         _ -> text ">="+        MO_U_Le         _ -> text "<="+        MO_U_Gt         _ -> char '>'+        MO_U_Lt         _ -> char '<'++        -- & Floating-point comparisons+        MO_F_Eq         _ -> text "=="+        MO_F_Ne         _ -> text "!="+        MO_F_Ge         _ -> text ">="+        MO_F_Le         _ -> text "<="+        MO_F_Gt         _ -> char '>'+        MO_F_Lt         _ -> char '<'++        -- Bitwise operations.  Not all of these may be supported at all+        -- sizes, and only integral MachReps are valid.+        MO_And          _ -> char '&'+        MO_Or           _ -> char '|'+        MO_Xor          _ -> char '^'+        MO_Not          _ -> char '~'+        MO_Shl          _ -> text "<<"+        MO_U_Shr        _ -> text ">>" -- unsigned shift right+        MO_S_Shr        _ -> text ">>" -- signed shift right++-- Conversions.  Some of these will be NOPs, but never those that convert+-- between ints and floats.+-- Floating-point conversions use the signed variant.+-- We won't know to generate (void*) casts here, but maybe from+-- context elsewhere++-- noop casts+        MO_UU_Conv from to | from == to -> empty+        MO_UU_Conv _from to -> parens (machRep_U_CType to)++        MO_SS_Conv from to | from == to -> empty+        MO_SS_Conv _from to -> parens (machRep_S_CType to)++        MO_XX_Conv from to | from == to -> empty+        MO_XX_Conv _from to -> parens (machRep_U_CType to)++        MO_FF_Conv from to | from == to -> empty+        MO_FF_Conv _from to -> parens (machRep_F_CType to)++        MO_SF_Conv _from to -> parens (machRep_F_CType to)+        MO_FS_Conv _from to -> parens (machRep_S_CType to)++        MO_S_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_S_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"+                                      ++ " should have been handled earlier!")+        MO_U_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_U_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"+                                      ++ " should have been handled earlier!")++        MO_V_Insert {}    -> pprTrace "offending mop:"+                                (text "MO_V_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"+                                      ++ " should have been handled earlier!")+        MO_V_Extract {}   -> pprTrace "offending mop:"+                                (text "MO_V_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"+                                      ++ " should have been handled earlier!")++        MO_V_Add {}       -> pprTrace "offending mop:"+                                (text "MO_V_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"+                                      ++ " should have been handled earlier!")+        MO_V_Sub {}       -> pprTrace "offending mop:"+                                (text "MO_V_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"+                                      ++ " should have been handled earlier!")+        MO_V_Mul {}       -> pprTrace "offending mop:"+                                (text "MO_V_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"+                                      ++ " should have been handled earlier!")++        MO_VS_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VS_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"+                                      ++ " should have been handled earlier!")+        MO_VS_Rem {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Rem")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"+                                      ++ " should have been handled earlier!")+        MO_VS_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"+                                      ++ " should have been handled earlier!")++        MO_VU_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VU_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"+                                      ++ " should have been handled earlier!")+        MO_VU_Rem {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Rem")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"+                                      ++ " should have been handled earlier!")++        MO_VF_Insert {}   -> pprTrace "offending mop:"+                                (text "MO_VF_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"+                                      ++ " should have been handled earlier!")+        MO_VF_Extract {}  -> pprTrace "offending mop:"+                                (text "MO_VF_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"+                                      ++ " should have been handled earlier!")++        MO_VF_Add {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"+                                      ++ " should have been handled earlier!")+        MO_VF_Sub {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"+                                      ++ " should have been handled earlier!")+        MO_VF_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"+                                      ++ " should have been handled earlier!")+        MO_VF_Mul {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"+                                      ++ " should have been handled earlier!")+        MO_VF_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VF_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"+                                      ++ " should have been handled earlier!")++        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"++signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints+signedOp (MO_S_Quot _)    = True+signedOp (MO_S_Rem  _)    = True+signedOp (MO_S_Neg  _)    = True+signedOp (MO_S_Ge   _)    = True+signedOp (MO_S_Le   _)    = True+signedOp (MO_S_Gt   _)    = True+signedOp (MO_S_Lt   _)    = True+signedOp (MO_S_Shr  _)    = True+signedOp (MO_SS_Conv _ _) = True+signedOp (MO_SF_Conv _ _) = True+signedOp _                = False++floatComparison :: MachOp -> Bool  -- comparison between float args+floatComparison (MO_F_Eq   _) = True+floatComparison (MO_F_Ne   _) = True+floatComparison (MO_F_Ge   _) = True+floatComparison (MO_F_Le   _) = True+floatComparison (MO_F_Gt   _) = True+floatComparison (MO_F_Lt   _) = True+floatComparison _             = False++-- ---------------------------------------------------------------------+-- tend to be implemented by foreign calls++pprCallishMachOp_for_C :: CallishMachOp -> SDoc++pprCallishMachOp_for_C mop+    = case mop of+        MO_F64_Pwr      -> text "pow"+        MO_F64_Sin      -> text "sin"+        MO_F64_Cos      -> text "cos"+        MO_F64_Tan      -> text "tan"+        MO_F64_Sinh     -> text "sinh"+        MO_F64_Cosh     -> text "cosh"+        MO_F64_Tanh     -> text "tanh"+        MO_F64_Asin     -> text "asin"+        MO_F64_Acos     -> text "acos"+        MO_F64_Atanh    -> text "atanh"+        MO_F64_Asinh    -> text "asinh"+        MO_F64_Acosh    -> text "acosh"+        MO_F64_Atan     -> text "atan"+        MO_F64_Log      -> text "log"+        MO_F64_Log1P    -> text "log1p"+        MO_F64_Exp      -> text "exp"+        MO_F64_ExpM1    -> text "expm1"+        MO_F64_Sqrt     -> text "sqrt"+        MO_F64_Fabs     -> text "fabs"+        MO_F32_Pwr      -> text "powf"+        MO_F32_Sin      -> text "sinf"+        MO_F32_Cos      -> text "cosf"+        MO_F32_Tan      -> text "tanf"+        MO_F32_Sinh     -> text "sinhf"+        MO_F32_Cosh     -> text "coshf"+        MO_F32_Tanh     -> text "tanhf"+        MO_F32_Asin     -> text "asinf"+        MO_F32_Acos     -> text "acosf"+        MO_F32_Atan     -> text "atanf"+        MO_F32_Asinh    -> text "asinhf"+        MO_F32_Acosh    -> text "acoshf"+        MO_F32_Atanh    -> text "atanhf"+        MO_F32_Log      -> text "logf"+        MO_F32_Log1P    -> text "log1pf"+        MO_F32_Exp      -> text "expf"+        MO_F32_ExpM1    -> text "expm1f"+        MO_F32_Sqrt     -> text "sqrtf"+        MO_F32_Fabs     -> text "fabsf"+        MO_ReadBarrier  -> text "load_load_barrier"+        MO_WriteBarrier -> text "write_barrier"+        MO_Memcpy _     -> text "memcpy"+        MO_Memset _     -> text "memset"+        MO_Memmove _    -> text "memmove"+        MO_Memcmp _     -> text "memcmp"+        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)+        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)+        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)+        (MO_Clz w)      -> ptext (sLit $ clzLabel w)+        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)+        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)+        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)+        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)+        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)+        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)++        MO_S_Mul2     {} -> unsupported+        MO_S_QuotRem  {} -> unsupported+        MO_U_QuotRem  {} -> unsupported+        MO_U_QuotRem2 {} -> unsupported+        MO_Add2       {} -> unsupported+        MO_AddWordC   {} -> unsupported+        MO_SubWordC   {} -> unsupported+        MO_AddIntC    {} -> unsupported+        MO_SubIntC    {} -> unsupported+        MO_U_Mul2     {} -> unsupported+        MO_Touch         -> unsupported+        (MO_Prefetch_Data _ ) -> unsupported+        --- we could support prefetch via "__builtin_prefetch"+        --- Not adding it for now+    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop+                            ++ " not supported!")++-- ---------------------------------------------------------------------+-- Useful #defines+--++mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc++mkJMP_ i = text "JMP_" <> parens i+mkFN_  i = text "FN_"  <> parens i -- externally visible function+mkIF_  i = text "IF_"  <> parens i -- locally visible++-- from includes/Stg.h+--+mkC_,mkW_,mkP_ :: SDoc++mkC_  = text "(C_)"        -- StgChar+mkW_  = text "(W_)"        -- StgWord+mkP_  = text "(P_)"        -- StgWord*++-- ---------------------------------------------------------------------+--+-- Assignments+--+-- Generating assignments is what we're all about, here+--+pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc++-- dest is a reg, rhs is a reg+pprAssign _ r1 (CmmReg r2)+   | isPtrReg r1 && isPtrReg r2+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]++-- dest is a reg, rhs is a CmmRegOff+pprAssign dflags r1 (CmmRegOff r2 off)+   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]+  where+        off1 = off `shiftR` wordShift dflags++        (op,off') | off >= 0  = (char '+', off1)+                  | otherwise = (char '-', -off1)++-- dest is a reg, rhs is anything.+-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting+-- the lvalue elicits a warning from new GCC versions (3.4+).+pprAssign _ r1 r2+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)+  | otherwise                    = mkAssign (pprExpr r2)+    where mkAssign x = if r1 == CmmGlobal BaseReg+                       then text "ASSIGN_BaseReg" <> parens x <> semi+                       else pprReg r1 <> text " = " <> x <> semi++-- ---------------------------------------------------------------------+-- Registers++pprCastReg :: CmmReg -> SDoc+pprCastReg reg+   | isStrangeTypeReg reg = mkW_ <> pprReg reg+   | otherwise            = pprReg reg++-- True if (pprReg reg) will give an expression with type StgPtr.  We+-- need to take care with pointer arithmetic on registers with type+-- StgPtr.+isFixedPtrReg :: CmmReg -> Bool+isFixedPtrReg (CmmLocal _) = False+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r++-- True if (pprAsPtrReg reg) will give an expression with type StgPtr+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.+isPtrReg :: CmmReg -> Bool+isPtrReg (CmmLocal _)                         = False+isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg++-- True if this global reg has type StgPtr+isFixedPtrGlobalReg :: GlobalReg -> Bool+isFixedPtrGlobalReg Sp    = True+isFixedPtrGlobalReg Hp    = True+isFixedPtrGlobalReg HpLim = True+isFixedPtrGlobalReg SpLim = True+isFixedPtrGlobalReg _     = False++-- True if in C this register doesn't have the type given by+-- (machRepCType (cmmRegType reg)), so it has to be cast.+isStrangeTypeReg :: CmmReg -> Bool+isStrangeTypeReg (CmmLocal _)   = False+isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g++isStrangeTypeGlobal :: GlobalReg -> Bool+isStrangeTypeGlobal CCCS                = True+isStrangeTypeGlobal CurrentTSO          = True+isStrangeTypeGlobal CurrentNursery      = True+isStrangeTypeGlobal BaseReg             = True+isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r++strangeRegType :: CmmReg -> Maybe SDoc+strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")+strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")+strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")+strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")+strangeRegType _ = Nothing++-- pprReg just prints the register name.+--+pprReg :: CmmReg -> SDoc+pprReg r = case r of+        CmmLocal  local  -> pprLocalReg local+        CmmGlobal global -> pprGlobalReg global++pprAsPtrReg :: CmmReg -> SDoc+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))+  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"+pprAsPtrReg other_reg = pprReg other_reg++pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg gr = case gr of+    VanillaReg n _ -> char 'R' <> int n  <> text ".w"+        -- pprGlobalReg prints a VanillaReg as a .w regardless+        -- Example:     R1.w = R1.w & (-0x8UL);+        --              JMP_(*R1.p);+    FloatReg   n   -> char 'F' <> int n+    DoubleReg  n   -> char 'D' <> int n+    LongReg    n   -> char 'L' <> int n+    Sp             -> text "Sp"+    SpLim          -> text "SpLim"+    Hp             -> text "Hp"+    HpLim          -> text "HpLim"+    CCCS           -> text "CCCS"+    CurrentTSO     -> text "CurrentTSO"+    CurrentNursery -> text "CurrentNursery"+    HpAlloc        -> text "HpAlloc"+    BaseReg        -> text "BaseReg"+    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+    GCEnter1       -> text "stg_gc_enter_1"+    GCFun          -> text "stg_gc_fun"+    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other++pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq++-- -----------------------------------------------------------------------------+-- Foreign Calls++pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCall ppr_fn cconv results args+  | not (is_cishCC cconv)+  = panic $ "pprCall: unknown calling convention"++  | otherwise+  =+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi+  where+     ppr_assign []           rhs = rhs+     ppr_assign [(one,hint)] rhs+         = pprLocalReg one <> text " = "+                 <> pprUnHint hint (localRegType one) <> rhs+     ppr_assign _other _rhs = panic "pprCall: multiple results"++     pprArg (expr, AddrHint)+        = cCast (text "void *") expr+        -- see comment by machRepHintCType below+     pprArg (expr, SignedHint)+        = sdocWithDynFlags $ \dflags ->+          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr+     pprArg (expr, _other)+        = pprExpr expr++     pprUnHint AddrHint   rep = parens (machRepCType rep)+     pprUnHint SignedHint rep = parens (machRepCType rep)+     pprUnHint _          _   = empty++-- Currently we only have these two calling conventions, but this might+-- change in the future...+is_cishCC :: CCallConv -> Bool+is_cishCC CCallConv    = True+is_cishCC CApiConv     = True+is_cishCC StdCallConv  = True+is_cishCC PrimCallConv = False+is_cishCC JavaScriptCallConv = False++-- ---------------------------------------------------------------------+-- Find and print local and external declarations for a list of+-- Cmm statements.+--+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})+pprTempAndExternDecls stmts+  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),+     vcat (map pprExternDecl (Map.keys lbls)))+  where (temps, lbls) = runTE (mapM_ te_BB stmts)++pprDataExterns :: [CmmStatic] -> SDoc+pprDataExterns statics+  = vcat (map pprExternDecl (Map.keys lbls))+  where (_, lbls) = runTE (mapM_ te_Static statics)++pprTempDecl :: LocalReg -> SDoc+pprTempDecl l@(LocalReg _ rep)+  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]++pprExternDecl :: CLabel -> SDoc+pprExternDecl lbl+  -- do not print anything for "known external" things+  | not (needsCDecl lbl) = empty+  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz+  | otherwise =+        hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"+             -- occasionally useful to see label type+             -- , text "/* ", pprDebugCLabel lbl, text " */"+             ]+ where+  label_type lbl | isBytesLabel lbl         = text "B_"+                 | isForeignLabel lbl && isCFunctionLabel lbl+                                            = text "FF_"+                 | isCFunctionLabel lbl     = text "F_"+                 | isStaticClosureLabel lbl = text "C_"+                 -- generic .rodata labels+                 | isSomeRODataLabel lbl    = text "RO_"+                 -- generic .data labels (common case)+                 | otherwise                = text "RW_"++  visibility+     | externallyVisibleCLabel lbl = char 'E'+     | otherwise                   = char 'I'++  -- If the label we want to refer to is a stdcall function (on Windows) then+  -- we must generate an appropriate prototype for it, so that the C compiler will+  -- add the @n suffix to the label (#2276)+  stdcall_decl sz = sdocWithDynFlags $ \dflags ->+        text "extern __attribute__((stdcall)) void " <> ppr lbl+        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))+        <> semi++type TEState = (UniqSet LocalReg, Map CLabel ())+newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)++instance Applicative TE where+      pure a = TE $ \s -> (a, s)+      (<*>) = ap++instance Monad TE where+   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'++te_lbl :: CLabel -> TE ()+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))++te_temp :: LocalReg -> TE ()+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))++runTE :: TE () -> TEState+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))++te_Static :: CmmStatic -> TE ()+te_Static (CmmStaticLit lit) = te_Lit lit+te_Static _ = return ()++te_BB :: CmmBlock -> TE ()+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last+  where (_, mid, last) = blockSplit block++te_Lit :: CmmLit -> TE ()+te_Lit (CmmLabel l) = te_lbl l+te_Lit (CmmLabelOff l _) = te_lbl l+te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1+te_Lit _ = return ()++te_Stmt :: CmmNode e x -> TE ()+te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e+te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r+te_Stmt (CmmUnsafeForeignCall target rs es)+  = do  te_Target target+        mapM_ te_temp rs+        mapM_ te_Expr es+te_Stmt (CmmCondBranch e _ _ _) = te_Expr e+te_Stmt (CmmSwitch e _)         = te_Expr e+te_Stmt (CmmCall { cml_target = e }) = te_Expr e+te_Stmt _                       = return ()++te_Target :: ForeignTarget -> TE ()+te_Target (ForeignTarget e _)      = te_Expr e+te_Target (PrimTarget{})           = return ()++te_Expr :: CmmExpr -> TE ()+te_Expr (CmmLit lit)            = te_Lit lit+te_Expr (CmmLoad e _)           = te_Expr e+te_Expr (CmmReg r)              = te_Reg r+te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es+te_Expr (CmmRegOff r _)         = te_Reg r+te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"++te_Reg :: CmmReg -> TE ()+te_Reg (CmmLocal l) = te_temp l+te_Reg _            = return ()+++-- ---------------------------------------------------------------------+-- C types for MachReps++cCast :: SDoc -> CmmExpr -> SDoc+cCast ty expr = parens ty <> pprExpr1 expr++cLoad :: CmmExpr -> CmmType -> SDoc+cLoad expr rep+    = sdocWithPlatform $ \platform ->+      if bewareLoadStoreAlignment (platformArch platform)+      then let decl = machRepCType rep <+> text "x" <> semi+               struct = text "struct" <+> braces (decl)+               packed_attr = text "__attribute__((packed))"+               cast = parens (struct <+> packed_attr <> char '*')+           in parens (cast <+> pprExpr1 expr) <> text "->x"+      else char '*' <> parens (cCast (machRepPtrCType rep) expr)+    where -- On these platforms, unaligned loads are known to cause problems+          bewareLoadStoreAlignment ArchAlpha    = True+          bewareLoadStoreAlignment ArchMipseb   = True+          bewareLoadStoreAlignment ArchMipsel   = True+          bewareLoadStoreAlignment (ArchARM {}) = True+          bewareLoadStoreAlignment ArchARM64    = True+          bewareLoadStoreAlignment ArchSPARC    = True+          bewareLoadStoreAlignment ArchSPARC64  = True+          -- Pessimistically assume that they will also cause problems+          -- on unknown arches+          bewareLoadStoreAlignment ArchUnknown  = True+          bewareLoadStoreAlignment _            = False++isCmmWordType :: DynFlags -> CmmType -> Bool+-- True of GcPtrReg/NonGcReg of native word size+isCmmWordType dflags ty = not (isFloatType ty)+                       && typeWidth ty == wordWidth dflags++-- This is for finding the types of foreign call arguments.  For a pointer+-- argument, we always cast the argument to (void *), to avoid warnings from+-- the C compiler.+machRepHintCType :: CmmType -> ForeignHint -> SDoc+machRepHintCType _   AddrHint   = text "void *"+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)+machRepHintCType rep _other     = machRepCType rep++machRepPtrCType :: CmmType -> SDoc+machRepPtrCType r+ = sdocWithDynFlags $ \dflags ->+   if isCmmWordType dflags r then text "P_"+                             else machRepCType r <> char '*'++machRepCType :: CmmType -> SDoc+machRepCType ty | isFloatType ty = machRep_F_CType w+                | otherwise      = machRep_U_CType w+                where+                  w = typeWidth ty++machRep_F_CType :: Width -> SDoc+machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?+machRep_F_CType W64 = text "StgDouble"+machRep_F_CType _   = panic "machRep_F_CType"++machRep_U_CType :: Width -> SDoc+machRep_U_CType w+ = sdocWithDynFlags $ \dflags ->+   case w of+   _ | w == wordWidth dflags -> text "W_"+   W8  -> text "StgWord8"+   W16 -> text "StgWord16"+   W32 -> text "StgWord32"+   W64 -> text "StgWord64"+   _   -> panic "machRep_U_CType"++machRep_S_CType :: Width -> SDoc+machRep_S_CType w+ = sdocWithDynFlags $ \dflags ->+   case w of+   _ | w == wordWidth dflags -> text "I_"+   W8  -> text "StgInt8"+   W16 -> text "StgInt16"+   W32 -> text "StgInt32"+   W64 -> text "StgInt64"+   _   -> panic "machRep_S_CType"+++-- ---------------------------------------------------------------------+-- print strings as valid C strings++pprStringInCStyle :: ByteString -> SDoc+pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))++-- ---------------------------------------------------------------------------+-- Initialising static objects with floating-point numbers.  We can't+-- just emit the floating point number, because C will cast it to an int+-- by rounding it.  We want the actual bit-representation of the float.+--+-- Consider a concrete C example:+--    double d = 2.5e-10;+--    float f  = 2.5e-10f;+--+--    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);+--    long long * l = &d; printf (" l: %016llX\n",   l[0]);+--    int * i = &f;       printf (" i: %08X\n",      i[0]);+-- Result on 64-bit LE (x86_64):+--     i2: E826D695 3DF12E0B+--      l: 3DF12E0BE826D695+--      i: 2F89705F+-- Result on 32-bit BE (m68k):+--     i2: 3DF12E0B E826D695+--      l: 3DF12E0BE826D695+--      i: 2F89705F+--+-- The trick here is to notice that binary representation does not+-- change much: only Word32 values get swapped on LE hosts / targets.++-- This is a hack to turn the floating point numbers into ints that we+-- can safely initialise to static locations.++castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)+castFloatToWord32Array = U.castSTUArray++castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)+castDoubleToWord64Array = U.castSTUArray++floatToWord :: DynFlags -> Rational -> CmmLit+floatToWord dflags r+  = runST (do+        arr <- newArray_ ((0::Int),0)+        writeArray arr 0 (fromRational r)+        arr' <- castFloatToWord32Array arr+        w32 <- readArray arr' 0+        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))+    )+    where wo | wordWidth dflags == W64+             , wORDS_BIGENDIAN dflags    = 32+             | otherwise                 = 0++floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit+floatPairToWord dflags r1 r2+  = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 (fromRational r1)+        writeArray arr 1 (fromRational r2)+        arr' <- castFloatToWord32Array arr+        w32_1 <- readArray arr' 0+        w32_2 <- readArray arr' 1+        return (pprWord32Pair w32_1 w32_2)+    )+    where pprWord32Pair w32_1 w32_2+              | wORDS_BIGENDIAN dflags =+                  CmmInt ((shiftL i1 32) .|. i2) W64+              | otherwise =+                  CmmInt ((shiftL i2 32) .|. i1) W64+              where i1 = toInteger w32_1+                    i2 = toInteger w32_2++doubleToWords :: DynFlags -> Rational -> [CmmLit]+doubleToWords dflags r+  = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 (fromRational r)+        arr' <- castDoubleToWord64Array arr+        w64 <- readArray arr' 0+        return (pprWord64 w64)+    )+    where targetWidth = wordWidth dflags+          targetBE    = wORDS_BIGENDIAN dflags+          pprWord64 w64+              | targetWidth == W64 =+                  [ CmmInt (toInteger w64) targetWidth ]+              | targetWidth == W32 =+                  [ CmmInt (toInteger targetW1) targetWidth+                  , CmmInt (toInteger targetW2) targetWidth+                  ]+              | otherwise = panic "doubleToWords.pprWord64"+              where (targetW1, targetW2)+                        | targetBE  = (wHi, wLo)+                        | otherwise = (wLo, wHi)+                    wHi = w64 `shiftR` 32+                    wLo = w64 .&. 0xFFFFffff++-- ---------------------------------------------------------------------------+-- Utils++wordShift :: DynFlags -> Int+wordShift dflags = widthInLog (wordWidth dflags)++commafy :: [SDoc] -> SDoc+commafy xs = hsep $ punctuate comma xs++-- Print in C hex format: 0x13fa+pprHexVal :: Integer -> Width -> SDoc+pprHexVal w rep+  | w < 0     = parens (char '-' <>+                    text "0x" <> intToDoc (-w) <> repsuffix rep)+  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+  where+        -- type suffix for literals:+        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to+        -- signed values for doing signed operations, but at all other+        -- times values are unsigned.  This also helps eliminate occasional+        -- warnings about integer overflow from gcc.++      repsuffix W64 = sdocWithDynFlags $ \dflags ->+               if cINT_SIZE       dflags == 8 then char 'U'+          else if cLONG_SIZE      dflags == 8 then text "UL"+          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"+          else panic "pprHexVal: Can't find a 64-bit type"+      repsuffix _ = char 'U'++      intToDoc :: Integer -> SDoc+      intToDoc i = case truncInt i of+                       0 -> char '0'+                       v -> go v++      -- We need to truncate value as Cmm backend does not drop+      -- redundant bits to ease handling of negative values.+      -- Thus the following Cmm code on 64-bit arch, like amd64:+      --     CInt v;+      --     v = {something};+      --     if (v == %lobits32(-1)) { ...+      -- leads to the following C code:+      --     StgWord64 v = (StgWord32)({something});+      --     if (v == 0xFFFFffffFFFFffffU) { ...+      -- Such code is incorrect as it promotes both operands to StgWord64+      -- and the whole condition is always false.+      truncInt :: Integer -> Integer+      truncInt i =+          case rep of+              W8  -> i `rem` (2^(8 :: Int))+              W16 -> i `rem` (2^(16 :: Int))+              W32 -> i `rem` (2^(32 :: Int))+              W64 -> i `rem` (2^(64 :: Int))+              _   -> panic ("pprHexVal/truncInt: C backend can't encode "+                            ++ show rep ++ " literals")++      go 0 = empty+      go w' = go q <> dig+           where+             (q,r) = w' `quotRem` 16+             dig | r < 10    = char (chr (fromInteger r + ord '0'))+                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
compiler/GHC/CoreToStg.hs view
@@ -723,7 +723,7 @@     (_, all_cafs_ccs) = getAllCAFsCC this_mod  -- Generate a non-top-level RHS. Cost-centre is always currentCCS,--- see Note [Cost-centre initialzation plan].+-- see Note [Cost-centre initialization plan]. mkStgRhs :: Id -> StgExpr -> StgRhs mkStgRhs bndr rhs   | StgLam bndrs body <- rhs@@ -837,7 +837,7 @@ -- For a let(rec)-bound variable, x, we record LiveInfo, the set of -- variables that are live if x is live.  This LiveInfo comprises --         (a) dynamic live variables (ones with a non-top-level binding)---         (b) static live variabes (CAFs or things that refer to CAFs)+--         (b) static live variables (CAFs or things that refer to CAFs) -- -- For "normal" variables (a) is just x alone.  If x is a let-no-escaped -- variable then x is represented by a code pointer and a stack pointer
compiler/GHC/CoreToStg/Prep.hs view
@@ -7,6 +7,8 @@  {-# LANGUAGE BangPatterns, CPP, MultiWayIf #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module GHC.CoreToStg.Prep (       corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,       lookupMkIntegerName, lookupIntegerSDataConName,@@ -228,7 +230,7 @@  mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] -- See Note [Data constructor workers]--- c.f. Note [Injecting implicit bindings] in TidyPgm+-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy mkDataConWorkers dflags mod_loc data_tycons   = [ NonRec id (tick_it (getName data_con) (Var id))                                 -- The ice is thin here, but it works@@ -926,8 +928,10 @@                    (_   : ss_rest, True)  -> (topDmd, ss_rest)                    (ss1 : ss_rest, False) -> (ss1,    ss_rest)                    ([],            _)     -> (topDmd, [])-            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $-                               splitFunTy_maybe fun_ty+            (arg_ty, res_ty) =+              case splitFunTy_maybe fun_ty of+                Just as -> as+                Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)         (fs, arg') <- cpeArg top_env ss1 arg arg_ty         rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest       CpeCast co ->@@ -1070,8 +1074,8 @@ foreign calls and unboxed tuple/sum constructors).  Note that eta expansion in CorePrep is very fragile due to the "prediction" of-CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta-expansion in CorePrep] in TidyPgm for details.  We previously saturated primop+CAFfyness made during tidying (see Note [CAFfyness inconsistencies due to eta+expansion in CorePrep] in GHC.Iface.Tidy for details.  We previously saturated primop applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in PrimOp.
+ compiler/GHC/Data/Bitmap.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns #-}++--+-- (c) The University of Glasgow 2003-2006+--++-- Functions for constructing bitmaps, which are used in various+-- places in generated code (stack frame liveness masks, function+-- argument liveness masks, SRT bitmaps).++module GHC.Data.Bitmap (+        Bitmap, mkBitmap,+        intsToBitmap, intsToReverseBitmap,+        mAX_SMALL_BITMAP_SIZE,+        seqBitmap,+  ) where++import GhcPrelude++import GHC.Runtime.Layout+import DynFlags+import Util++import Data.Bits++{-|+A bitmap represented by a sequence of 'StgWord's on the /target/+architecture.  These are used for bitmaps in info tables and other+generated code which need to be emitted as sequences of StgWords.+-}+type Bitmap = [StgWord]++-- | Make a bitmap from a sequence of bits+mkBitmap :: DynFlags -> [Bool] -> Bitmap+mkBitmap _ [] = []+mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest+  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff++chunkToBitmap :: DynFlags -> [Bool] -> StgWord+chunkToBitmap dflags chunk =+  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]+  where+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.+-- eg. @[0,1,3], size 4 ==> 0xb@.+--+-- The list of @Int@s /must/ be already sorted.+intsToBitmap :: DynFlags+             -> Int        -- ^ size in bits+             -> [Int]      -- ^ sorted indices of ones+             -> Bitmap+intsToBitmap dflags size = go 0+  where+    word_sz = wORD_SIZE_IN_BITS dflags+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++    -- It is important that we maintain strictness here.+    -- See Note [Strictness when building Bitmaps].+    go :: Int -> [Int] -> Bitmap+    go !pos slots+      | size <= pos = []+      | otherwise =+        (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) :+          go (pos + word_sz) rest+      where+        (these,rest) = span (< (pos + word_sz)) slots++-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.+-- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,+-- just to make the bitmap easier to read).+--+-- The list of @Int@s /must/ be already sorted and duplicate-free.+intsToReverseBitmap :: DynFlags+                    -> Int      -- ^ size in bits+                    -> [Int]    -- ^ sorted indices of zeros free of duplicates+                    -> Bitmap+intsToReverseBitmap dflags size = go 0+  where+    word_sz = wORD_SIZE_IN_BITS dflags+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++    -- It is important that we maintain strictness here.+    -- See Note [Strictness when building Bitmaps].+    go :: Int -> [Int] -> Bitmap+    go !pos slots+      | size <= pos = []+      | otherwise =+        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :+          go (pos + word_sz) rest+      where+        (these,rest) = span (< (pos + word_sz)) slots+        remain = size - pos+        init+          | remain >= word_sz = -1+          | otherwise         = (1 `shiftL` remain) - 1++{-++Note [Strictness when building Bitmaps]+========================================++One of the places where @Bitmap@ is used is in in building Static Reference+Tables (SRTs) (in @GHC.Cmm.Info.Build.procpointSRT@). In #7450 it was noticed+that some test cases (particularly those whose C-- have large numbers of CAFs)+produced large quantities of allocations from this function.++The source traced back to 'intsToBitmap', which was lazily subtracting the word+size from the elements of the tail of the @slots@ list and recursively invoking+itself with the result. This resulted in large numbers of subtraction thunks+being built up. Here we take care to avoid passing new thunks to the recursive+call. Instead we pass the unmodified tail along with an explicit position+accumulator, which get subtracted in the fold when we compute the Word.++-}++{- |+Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.+Some kinds of bitmap pack a size\/bitmap into a single word if+possible, or fall back to an external pointer when the bitmap is too+large.  This value represents the largest size of bitmap that can be+packed into a single word.+-}+mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int+mAX_SMALL_BITMAP_SIZE dflags+ | wORD_SIZE dflags == 4 = 27+ | otherwise             = 58++seqBitmap :: Bitmap -> a -> a+seqBitmap = seqList+
compiler/GHC/HsToCore/PmCheck.hs view
@@ -46,12 +46,14 @@ import Var (EvVar) import Coercion import TcEvidence+import TcType (evVarPred) import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} DsBinds (dsHsWrapper) import DsUtils (selectMatchVar) import MatchLit (dsLit, dsOverLit) import DsMonad import Bag+import OrdList import TyCoRep import Type import DsUtils       (isTrueLHsExpr)@@ -75,7 +77,7 @@   "GADTs Meet Their Match:      Pattern-matching Warnings That Account for GADTs, Guards, and Laziness" -    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf+    https://www.microsoft.com/en-us/research/wp-content/uploads/2016/08/gadtpm-acm.pdf  %************************************************************************ %*                                                                      *@@ -87,9 +89,8 @@ -- | A very simple language for pattern guards. Let bindings, bang patterns, -- and matching variables against flat constructor patterns. data PmGrd-  = -- | @PmCon x K tvs dicts args@ corresponds to a-    -- @K tvs dicts args <- x@ guard. The @tvs@ and @args@ are bound in this-    -- construct, the @x@ is just a use.+  = -- | @PmCon x K dicts args@ corresponds to a @K dicts args <- x@ guard.+    -- The @args@ are bound in this construct, the @x@ is just a use.     -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'.     PmCon {       pm_id          :: !Id,@@ -113,62 +114,13 @@  -- | Should not be user-facing. instance Outputable PmGrd where-  ppr (PmCon x alt _con_tvs _con_dicts con_args)+  ppr (PmCon x alt _tvs _con_dicts con_args)     = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]   ppr (PmBang x) = char '!' <> ppr x   ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr]  type GrdVec = [PmGrd] --- | Each 'Delta' is proof (i.e., a model of the fact) that some values are not--- covered by a pattern match. E.g. @f Nothing = <rhs>@ might be given an--- uncovered set @[x :-> Just y]@ or @[x /= Nothing]@, where @x@ is the variable--- matching against @f@'s first argument.-type Uncovered = [Delta]---- Instead of keeping the whole sets in memory, we keep a boolean for both the--- covered and the divergent set (we store the uncovered set though, since we--- want to print it). For both the covered and the divergent we have:------   True <=> The set is non-empty------ hence:---  C = True             ==> Useful clause (no warning)---  C = False, D = True  ==> Clause with inaccessible RHS---  C = False, D = False ==> Redundant clause--data Covered = Covered | NotCovered-  deriving Show--instance Outputable Covered where-  ppr = text . show---- Like the or monoid for booleans--- Covered = True, Uncovered = False-instance Semi.Semigroup Covered where-  Covered <> _ = Covered-  _ <> Covered = Covered-  NotCovered <> NotCovered = NotCovered--instance Monoid Covered where-  mempty = NotCovered-  mappend = (Semi.<>)--data Diverged = Diverged | NotDiverged-  deriving Show--instance Outputable Diverged where-  ppr = text . show--instance Semi.Semigroup Diverged where-  Diverged <> _ = Diverged-  _ <> Diverged = Diverged-  NotDiverged <> NotDiverged = NotDiverged--instance Monoid Diverged where-  mempty = NotDiverged-  mappend = (Semi.<>)- data Precision = Approximate | Precise   deriving (Eq, Show) @@ -176,79 +128,131 @@   ppr = text . show  instance Semi.Semigroup Precision where-  Approximate <> _ = Approximate-  _ <> Approximate = Approximate   Precise <> Precise = Precise+  _       <> _       = Approximate  instance Monoid Precision where   mempty = Precise   mappend = (Semi.<>) --- | A triple <C,U,D> of covered, uncovered, and divergent sets.------ Also stores a flag 'presultApprox' denoting whether we ran into the--- 'maxPmCheckModels' limit for the purpose of hints in warning messages to--- maybe increase the limit.-data PartialResult = PartialResult {-                        presultCovered   :: Covered-                      , presultUncovered :: Uncovered-                      , presultDivergent :: Diverged-                      , presultApprox    :: Precision }+-- | Means by which we identify a RHS for later pretty-printing in a warning+-- message. 'SDoc' for the equation to show, 'Located' for the location.+type RhsInfo = Located SDoc -emptyPartialResult :: PartialResult-emptyPartialResult = PartialResult { presultUncovered = mempty-                                   , presultCovered   = mempty-                                   , presultDivergent = mempty-                                   , presultApprox    = mempty }+-- | A representation of the desugaring to 'PmGrd's of all clauses of a+-- function definition/pattern match/etc.+data GrdTree+  = Rhs !RhsInfo+  | Guard !PmGrd !GrdTree+  -- ^ @Guard grd t@ will try to match @grd@ and on success continue to match+  -- @t@. Falls through if either match fails. Models left-to-right semantics+  -- of pattern matching.+  | Sequence !GrdTree !GrdTree+  -- ^ @Sequence l r@ first matches against @l@, and then matches all+  -- fallen-through values against @r@. Models top-to-bottom semantics of+  -- pattern matching.+  | Empty+  -- ^ A @GrdTree@ that always fails. Most useful for+  -- Note [Checking EmptyCase]. A neutral element to 'Sequence'. -combinePartialResults :: PartialResult -> PartialResult -> PartialResult-combinePartialResults (PartialResult cs1 vsa1 ds1 ap1) (PartialResult cs2 vsa2 ds2 ap2)-  = PartialResult (cs1 Semi.<> cs2)-                  (vsa1 Semi.<> vsa2)-                  (ds1 Semi.<> ds2)-                  (ap1 Semi.<> ap2) -- the result is approximate if either is+-- | The digest of 'checkGrdTree', representing the annotated pattern-match+-- tree. 'redundantAndInaccessibleRhss' can figure out redundant and proper+-- inaccessible RHSs from this.+data AnnotatedTree+  = AccessibleRhs !RhsInfo+  -- ^ A RHS deemed accessible.+  | InaccessibleRhs !RhsInfo+  -- ^ A RHS deemed inaccessible; no value could possibly reach it.+  | MayDiverge !AnnotatedTree+  -- ^ Asserts that the tree may force diverging values, so not all of its+  -- clauses can be redundant.+  | SequenceAnn !AnnotatedTree !AnnotatedTree+  -- ^ Mirrors 'Sequence' for preserving the skeleton of a 'GrdTree's.+  | EmptyAnn+  -- ^ Mirrors 'Empty' for preserving the skeleton of a 'GrdTree's. -instance Outputable PartialResult where-  ppr (PartialResult c unc d pc)-    = hang (text "PartialResult" <+> ppr c <+> ppr d <+> ppr pc) 2 (ppr_unc unc)+pprRhsInfo :: RhsInfo -> SDoc+pprRhsInfo (L (RealSrcSpan rss) _) = ppr (srcSpanStartLine rss)+pprRhsInfo (L s _)                 = ppr s++instance Outputable GrdTree where+  ppr (Rhs info)      = text "->" <+> pprRhsInfo info+  -- Format guards as "| True <- x, let x = 42, !z"+  ppr g@Guard{} = fsep (prefix (map ppr grds)) <+> ppr t     where-      ppr_unc = braces . fsep . punctuate comma . map ppr+      (t, grds)                  = collect_grds g+      collect_grds (Guard grd t) = (grd :) <$> collect_grds t+      collect_grds t             = (t, [])+      prefix []                  = []+      prefix (s:sdocs)           = char '|' <+> s : map (comma <+>) sdocs+  -- Format nested Sequences in blocks "{ grds1; grds2; ... }"+  ppr t@Sequence{}    = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space)+    where+      collect_seqs (Sequence l r) = collect_seqs l ++ collect_seqs r+      collect_seqs t              = [ppr t]+  ppr Empty          = text "<empty case>" -instance Semi.Semigroup PartialResult where-  (<>) = combinePartialResults+instance Outputable AnnotatedTree where+  ppr (AccessibleRhs info)   = pprRhsInfo info+  ppr (InaccessibleRhs info) = text "inaccessible" <+> pprRhsInfo info+  ppr (MayDiverge t)         = text "div" <+> ppr t+    -- Format nested Sequences in blocks "{ grds1; grds2; ... }"+  ppr t@SequenceAnn{}        = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space)+    where+      collect_seqs (SequenceAnn l r) = collect_seqs l ++ collect_seqs r+      collect_seqs t                 = [ppr t]+  ppr EmptyAnn               = text "<empty case>" -instance Monoid PartialResult where-  mempty = emptyPartialResult-  mappend = (Semi.<>)+newtype Deltas = MkDeltas (Bag Delta) --- | Pattern check result------ * Redundant clauses--- * Not-covered clauses (or their type, if no pattern is available)--- * Clauses with inaccessible RHS--- * A flag saying whether we ran into the 'maxPmCheckModels' limit for the---   purpose of suggesting to crank it up in the warning message------ More details about the classification of clauses into useful, redundant--- and with inaccessible right hand side can be found here:------     https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check----data PmResult =-  PmResult {-      pmresultRedundant    :: [Located [LPat GhcTc]]-    , pmresultUncovered    :: [Delta]-    , pmresultInaccessible :: [Located [LPat GhcTc]]-    , pmresultApproximate  :: Precision }+instance Outputable Deltas where+  ppr (MkDeltas deltas) = ppr deltas -instance Outputable PmResult where-  ppr pmr = hang (text "PmResult") 2 $ vcat-    [ text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)-    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)-    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)-    , text "pmresultApproximate" <+> ppr (pmresultApproximate pmr)-    ]+instance Semigroup Deltas where+  MkDeltas l <> MkDeltas r = MkDeltas (l `unionBags` r) +liftDeltasM :: Monad m => (Delta -> m (Maybe Delta)) -> Deltas -> m Deltas+liftDeltasM f (MkDeltas ds) = MkDeltas . catBagMaybes <$> (traverse f ds)++-- | Lift 'addPmCts' over 'Deltas'.+addPmCtsDeltas :: Deltas -> PmCts -> DsM Deltas+addPmCtsDeltas deltas cts = liftDeltasM (\d -> addPmCts d cts) deltas++-- | 'addPmCtsDeltas' a single 'PmCt'.+addPmCtDeltas :: Deltas -> PmCt -> DsM Deltas+addPmCtDeltas deltas ct = addPmCtsDeltas deltas (unitBag ct)++-- | Test if any of the 'Delta's is inhabited. Currently this is pure, because+-- we preserve the invariant that there are no uninhabited 'Delta's. But that+-- could change in the future, for example by implementing this function in+-- terms of @notNull <$> provideEvidence 1 ds@.+isInhabited :: Deltas -> DsM Bool+isInhabited (MkDeltas ds) = pure (not (null ds))++-- | Pattern-match check result+data CheckResult+  = CheckResult+  { cr_clauses :: !AnnotatedTree+  -- ^ Captures redundancy info for each clause in the original program.+  --   (for -Woverlapping-patterns)+  , cr_uncov   :: !Deltas+  -- ^ The set of uncovered values falling out at the bottom.+  --   (for -Wincomplete-patterns)+  , cr_approx  :: !Precision+  -- ^ A flag saying whether we ran into the 'maxPmCheckModels' limit for the+  --   purpose of suggesting to crank it up in the warning message+  }++instance Outputable CheckResult where+  ppr (CheckResult c unc pc)+    = text "CheckResult" <+> ppr_precision pc <+> braces (fsep+        [ field "clauses" c <> comma+        , field "uncov" unc])+    where+      ppr_precision Precise     = empty+      ppr_precision Approximate = text "(Approximate)"+      field name value = text name <+> equals <+> ppr value+ {- %************************************************************************ %*                                                                      *@@ -257,32 +261,22 @@ %************************************************************************ -} --- | Check a single pattern binding (let)+-- | Check a single pattern binding (let) for exhaustiveness. checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()-checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do+checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do   tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])-  res <- checkSingle' locn var p-  dsPmWarn dflags ctxt [var] res---- | Check a single pattern binding (let)-checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> DsM PmResult-checkSingle' locn var p = do-  fam_insts <- dsGetFamInstEnvs-  grds      <- translatePat fam_insts var p-  missing   <- getPmDelta-  tracePm "checkSingle': missing" (ppr missing)-  PartialResult cs us ds pc <- pmCheck grds [] 1 missing-  dflags <- getDynFlags-  us' <- getNFirstUncovered [var] (maxUncoveredPatterns dflags + 1) us-  let plain = PmResult { pmresultRedundant    = []-                       , pmresultUncovered    = us'-                       , pmresultInaccessible = []-                       , pmresultApproximate  = pc }-  return $ case (cs,ds) of-    (Covered   , _          ) -> plain                              -- useful-    (NotCovered, NotDiverged) -> plain { pmresultRedundant = m    } -- redundant-    (NotCovered, Diverged   ) -> plain { pmresultInaccessible = m } -- inaccessible rhs-  where m = [L locn [L locn p]]+  -- We only ever need to run this in a context where we need exhaustivity+  -- warnings (so not in pattern guards or comprehensions, for example, because+  -- they are perfectly fine to fail).+  -- Omitting checking this flag emits redundancy warnings twice in obscure+  -- cases like #17646.+  when (exhaustive dflags kind) $ do+    missing   <- MkDeltas . unitBag <$> getPmDelta+    tracePm "checkSingle: missing" (ppr missing)+    fam_insts <- dsGetFamInstEnvs+    grd_tree  <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p+    res <- checkGrdTree grd_tree missing+    dsPmWarn dflags ctxt [var] res  -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions.@@ -310,66 +304,18 @@                                , text "Matches:"])                                2                                (vcat (map ppr matches)))-  res <- checkMatches' vars matches-  dsPmWarn dflags ctxt vars res --- | Check a matchgroup (case, functions, etc.).-checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM PmResult-checkMatches' vars matches = do-  init_delta <- getPmDelta+  init_deltas <- MkDeltas . unitBag <$> getPmDelta   missing <- case matches of     -- This must be an -XEmptyCase. See Note [Checking EmptyCase]-    [] | [var] <- vars -> maybeToList <$> addTmCt init_delta (TmVarNonVoid var)-    _                  -> pure [init_delta]-  tracePm "checkMatches': missing" (ppr missing)-  (rs,us,ds,pc) <- go matches missing-  dflags <- getDynFlags-  us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us-  return $ PmResult {-                pmresultRedundant    = map hsLMatchToLPats rs-              , pmresultUncovered    = us'-              , pmresultInaccessible = map hsLMatchToLPats ds-              , pmresultApproximate  = pc }-  where-    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered-       -> DsM ( [LMatch GhcTc (LHsExpr GhcTc)]-              , Uncovered-              , [LMatch GhcTc (LHsExpr GhcTc)]-              , Precision)-    go []     missing = return ([], missing, [], Precise)-    go (m:ms) missing = do-      tracePm "checkMatches': go" (ppr m)-      dflags             <- getDynFlags-      fam_insts          <- dsGetFamInstEnvs-      (clause, guards)   <- translateMatch fam_insts vars m-      let limit                     = maxPmCheckModels dflags-          n_siblings                = length missing-          throttled_check delta     =-            snd <$> throttle limit (pmCheck clause guards) n_siblings delta--      r@(PartialResult cs missing' ds pc1) <- runMany throttled_check missing--      tracePm "checkMatches': go: res" (ppr r)-      (rs, final_u, is, pc2)  <- go ms missing'-      return $ case (cs, ds) of-        -- useful-        (Covered,  _    )        -> (rs, final_u,    is, pc1 Semi.<> pc2)-        -- redundant-        (NotCovered, NotDiverged) -> (m:rs, final_u, is, pc1 Semi.<> pc2)-        -- inaccessible-        (NotCovered, Diverged )   -> (rs, final_u, m:is, pc1 Semi.<> pc2)--    hsLMatchToLPats :: LMatch id body -> Located [LPat id]-    hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats-    hsLMatchToLPats _                               = panic "checkMatches'"+    [] | [var] <- vars -> addPmCtDeltas init_deltas (PmNotBotCt var)+    _                  -> pure init_deltas+  tracePm "checkMatches: missing" (ppr missing)+  fam_insts <- dsGetFamInstEnvs+  grd_tree  <- mkGrdTreeMany [] <$> mapM (translateMatch fam_insts vars) matches+  res <- checkGrdTree grd_tree missing -getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]-getNFirstUncovered _    0 _              = pure []-getNFirstUncovered _    _ []             = pure []-getNFirstUncovered vars n (delta:deltas) = do-  front <- provideEvidence vars n delta-  back <- getNFirstUncovered vars (n - length front) deltas-  pure (front ++ back)+  dsPmWarn dflags ctxt vars res  {- Note [Checking EmptyCase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -417,7 +363,8 @@ --   @mkListGrds "a" "[(x, True <- x),(y, !y)]"@ -- to --   @"[(x:b) <- a, True <- x, (y:c) <- b, seq y True, [] <- c]"@--- where b,c are freshly allocated in @mkListGrds@ and a is the match variable.+-- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match+-- variable. mkListGrds :: Id -> [(Id, GrdVec)] -> DsM GrdVec -- See Note [Order of guards matter] for why we need to intertwine guards -- on list elements.@@ -432,9 +379,10 @@ mkPmLitGrds x (PmLit _ (PmLitString s)) = do   -- We translate String literals to list literals for better overlap reasoning.   -- It's a little unfortunate we do this here rather than in-  -- 'GHC.HsToCore.PmCheck.Oracle.trySolve' and 'GHC.HsToCore.PmCheck.Oracle.addRefutableAltCon', but it's so much-  -- simpler here.-  -- See Note [Representation of Strings in TmState] in GHC.HsToCore.PmCheck.Oracle+  -- 'GHC.HsToCore.PmCheck.Oracle.trySolve' and+  -- 'GHC.HsToCore.PmCheck.Oracle.addRefutableAltCon', but it's so much simpler+  -- here. See Note [Representation of Strings in TmState] in+  -- GHC.HsToCore.PmCheck.Oracle   vars <- traverse mkPmId (take (lengthFS s) (repeat charTy))   let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c))   char_grdss <- zipWithM mk_char_lit vars (unpackFS s)@@ -654,30 +602,37 @@       --      1.         2.           3.       pure (con_grd : bang_grds ++ arg_grds) +mkGrdTreeRhs :: Located SDoc -> GrdVec -> GrdTree+mkGrdTreeRhs sdoc = foldr Guard (Rhs sdoc)++mkGrdTreeMany :: GrdVec -> [GrdTree] -> GrdTree+mkGrdTreeMany _    []    = Empty+mkGrdTreeMany grds trees = foldr Guard (foldr1 Sequence trees) grds+ -- Translate a single match translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)-               -> DsM (GrdVec, [GrdVec])-translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss }))-  = do-      pats'   <- concat <$> zipWithM (translateLPat fam_insts) vars pats-      guards' <- mapM (translateGuards fam_insts) guards-      -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards'])-      return (pats', guards')-      where-        extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]-        extractGuards (L _ (GRHS _ gs _)) = map unLoc gs-        extractGuards _                   = panic "translateMatch"--        guards = map extractGuards (grhssGRHSs grhss)-translateMatch _ _ _ = panic "translateMatch"+               -> DsM GrdTree+translateMatch fam_insts vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do+  pats'   <- concat <$> zipWithM (translateLPat fam_insts) vars pats+  grhss' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss)+  -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss'])+  return (mkGrdTreeMany pats' grhss')+translateMatch _ _ (L _ (XMatch _)) = panic "translateMatch"  -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to simpler PmGrds --- | Translate a list of guard statements to a 'GrdVec'-translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM GrdVec-translateGuards fam_insts guards =-  concat <$> mapM (translateGuard fam_insts) guards+-- | Translate a guarded right-hand side to a single 'GrdTree'+translateLGRHS :: FamInstEnvs -> SrcSpan -> [LPat GhcTc] -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM GrdTree+translateLGRHS fam_insts match_loc pats (L _loc (GRHS _ gs _)) =+  -- _loc apparently points to the match separator that comes after the guards..+  mkGrdTreeRhs loc_sdoc . concat <$> mapM (translateGuard fam_insts . unLoc) gs+    where+      loc_sdoc+        | null gs   = L match_loc (sep (map ppr pats))+        | otherwise = L grd_loc   (sep (map ppr pats) <+> vbar <+> interpp'SP gs)+      L grd_loc _ = head gs+translateLGRHS _ _ _ (L _ (XGRHS _)) = panic "translateLGRHS"  -- | Translate a guard statement to a 'GrdVec' translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec@@ -802,24 +757,12 @@ and report @f _ _@ as missing, which is a superset of the actual missing matches. But soundness means we will never fail to report a missing match. -This mechanism is implemented in the higher-order function 'throttle'.--Note [Combinatorial explosion in guards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Function with many clauses and deeply nested guards like in #11195 tend to-overwhelm the checker because they lead to exponential splitting behavior.-See the comments on #11195 on refinement trees. Every guard refines the-disjunction of Deltas by another split. This no different than the ConVar case,-but in stark contrast we mostly don't get any useful information out of that-split! Hence splitting k-fold just means having k-fold more work. The problem-exacerbates for larger k, because it gets even more unlikely that we can handle-all of the arising Deltas better than just continue working on the original-Delta.+This mechanism is implemented in 'throttle'. -We simply apply the same mechanism as in Note [Countering exponential blowup].-But we don't want to forget about actually useful info from pattern match-clauses just because we had one clause with many guards. So we set the limit for-guards much lower.+Guards are an extreme example in this regard, with #11195 being a particularly+dreadful example: Since their RHS are often pretty much unique, we split on a+variable (the one representing the RHS) that doesn't occur anywhere else in the+program, so we don't actually get useful information out of that split!  Note [Translate CoPats] ~~~~~~~~~~~~~~~~~~~~~~~@@ -938,183 +881,102 @@ {- %************************************************************************ %*                                                                      *-            Heart of the algorithm: Function pmCheck+            Heart of the algorithm: checkGrdTree %*                                                                      * %************************************************************************--Main functions are:--* pmCheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult+-} -  This function implements functions `covered`, `uncovered` and-  `divergent` from the paper at once. Calls out to the auxiliary function-  `pmCheckGuards` for handling (possibly multiple) guarded RHSs when the whole-  clause is checked. Slightly different from the paper because it does not even-  produce the covered and uncovered sets. Since we only care about whether a-  clause covers SOMETHING or if it may forces ANY argument, we only store a-  boolean in both cases, for efficiency.+-- | @throttle limit old new@ returns @old@ if the number of 'Delta's in @new@+-- is exceeding the given @limit@ and the @old@ number of 'Delta's.+-- See Note [Countering exponential blowup].+throttle :: Int -> Deltas -> Deltas -> (Precision, Deltas)+throttle limit old@(MkDeltas old_ds) new@(MkDeltas new_ds)+  --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined+  | length new_ds > max limit (length old_ds) = (Approximate, old)+  | otherwise                                 = (Precise,     new) -* pmCheckGuards :: [PatVec] -> ValVec -> Delta -> DsM PartialResult+-- | Matching on a newtype doesn't force anything.+-- See Note [Divergence of Newtype matches] in Oracle.+conMatchForces :: PmAltCon -> Bool+conMatchForces (PmAltConLike (RealDataCon dc))+  | isNewTyCon (dataConTyCon dc) = False+conMatchForces _                 = True -  Processes the guards.--}+-- | Makes sure that we only wrap a single 'MayDiverge' around an+-- 'AnnotatedTree', purely for esthetic reasons.+mayDiverge :: AnnotatedTree -> AnnotatedTree+mayDiverge a@(MayDiverge _) = a+mayDiverge a                = MayDiverge a --- | @throttle limit f n delta@ executes the pattern match action @f@ but--- replaces the 'Uncovered' set by @[delta]@ if not doing so would lead to--- too many Deltas to check.------ See Note [Countering exponential blowup] and--- Note [Combinatorial explosion in guards]+-- | Computes two things: ----- How many is "too many"? @throttle@ assumes that the pattern match action--- will be executed against @n@ similar other Deltas, its "siblings". Now, by--- observing the branching factor (i.e. the number of children) of executing--- the action, we can estimate how many Deltas there would be in the next--- generation. If we find that this number exceeds @limit@, we do--- "birth control": We simply don't allow a branching factor of more than 1.--- Otherwise we just return the singleton set of the original @delta@.--- This amounts to forgetting about the refined facts we got from running the--- action.-throttle :: Int -> (Int -> Delta -> DsM PartialResult) -> Int -> Delta -> DsM (Int, PartialResult)-throttle limit f n_siblings delta = do-  res <- f n_siblings delta-  let n_own_children = length (presultUncovered res)-  let n_next_gen = n_siblings * n_own_children-  -- Birth control!-  if n_next_gen <= limit || n_own_children <= 1-    then pure (n_next_gen, res)-    else pure (n_siblings, res { presultUncovered = [delta], presultApprox = Approximate })---- | Map a pattern matching action processing a single 'Delta' over a--- 'Uncovered' set and return the combined 'PartialResult's.-runMany :: (Delta -> DsM PartialResult) -> Uncovered -> DsM PartialResult-runMany f unc = mconcat <$> traverse f unc+--   * The set of uncovered values not matched by any of the clauses of the+--     'GrdTree'. Note that 'PmCon' guards are the only way in which values+--     fall through from one 'Many' branch to the next.+--   * An 'AnnotatedTree' that contains divergence and inaccessibility info+--     for all clauses. Will be fed to 'redundantAndInaccessibleRhss' for+--     presenting redundant and proper innaccessible RHSs to the user.+checkGrdTree' :: GrdTree -> Deltas -> DsM CheckResult+-- RHS: Check that it covers something and wrap Inaccessible if not+checkGrdTree' (Rhs sdoc) deltas = do+  is_covered <- isInhabited deltas+  let clauses = if is_covered then AccessibleRhs sdoc else InaccessibleRhs sdoc+  pure CheckResult+    { cr_clauses = clauses+    , cr_uncov   = MkDeltas emptyBag+    , cr_approx  = Precise }+-- let x = e: Refine with x ~ e+checkGrdTree' (Guard (PmLet x e) tree) deltas = do+  deltas' <- addPmCtDeltas deltas (PmCoreCt x e)+  checkGrdTree' tree deltas'+-- Bang x: Diverge on x ~ ⊥, refine with x /~ ⊥+checkGrdTree' (Guard (PmBang x) tree) deltas = do+  has_diverged <- addPmCtDeltas deltas (PmBotCt x) >>= isInhabited+  deltas' <- addPmCtDeltas deltas (PmNotBotCt x)+  res <- checkGrdTree' tree deltas'+  pure res{ cr_clauses = applyWhen has_diverged mayDiverge (cr_clauses res) }+-- Con: Diverge on x ~ ⊥, fall through on x /~ K and refine with x ~ K ys+--      and type info+checkGrdTree' (Guard (PmCon x con tvs dicts args) tree) deltas = do+  has_diverged <-+    if conMatchForces con+      then addPmCtDeltas deltas (PmBotCt x) >>= isInhabited+      else pure False+  unc_this <- addPmCtDeltas deltas (PmNotConCt x con)+  deltas' <- addPmCtsDeltas deltas $+    listToBag (PmTyCt . evVarPred <$> dicts) `snocBag` PmConCt x con tvs args+  CheckResult tree' unc_inner prec <- checkGrdTree' tree deltas'+  limit <- maxPmCheckModels <$> getDynFlags+  let (prec', unc') = throttle limit deltas (unc_this Semi.<> unc_inner)+  pure CheckResult+    { cr_clauses = applyWhen has_diverged mayDiverge tree'+    , cr_uncov = unc'+    , cr_approx = prec Semi.<> prec' }+-- Sequence: Thread residual uncovered sets from equation to equation+checkGrdTree' (Sequence l r) unc_0 = do+  CheckResult l' unc_1 prec_l <- checkGrdTree' l unc_0+  CheckResult r' unc_2 prec_r <- checkGrdTree' r unc_1+  pure CheckResult+    { cr_clauses = SequenceAnn l' r'+    , cr_uncov = unc_2+    , cr_approx = prec_l Semi.<> prec_r }+-- Empty: Fall through for all values+checkGrdTree' Empty unc = do+  pure CheckResult+    { cr_clauses = EmptyAnn+    , cr_uncov = unc+    , cr_approx = Precise } --- | Print diagnostic info and actually call 'pmCheck''.-pmCheck :: GrdVec -> [GrdVec] -> Int -> Delta -> DsM PartialResult-pmCheck ps guards n delta = do-  tracePm "pmCheck {" $ vcat [ ppr n <> colon-                           , hang (text "patterns:") 2 (ppr ps)-                           , hang (text "guards:") 2 (ppr guards)-                           , ppr delta ]-  res <- pmCheck' ps guards n delta+-- | Print diagnostic info and actually call 'checkGrdTree''.+checkGrdTree :: GrdTree -> Deltas -> DsM CheckResult+checkGrdTree guards deltas = do+  tracePm "checkGrdTree {" $ vcat [ ppr guards+                                  , ppr deltas ]+  res <- checkGrdTree' guards deltas   tracePm "}:" (ppr res) -- braces are easier to match by tooling   return res --- | Lifts 'pmCheck' over a 'DsM (Maybe Delta)'.-pmCheckM :: GrdVec -> [GrdVec] -> Int -> DsM (Maybe Delta) -> DsM PartialResult-pmCheckM ps guards n m_mb_delta = m_mb_delta >>= \case-  Nothing    -> pure mempty-  Just delta -> pmCheck ps guards n delta---- | Check the list of mutually exclusive guards-pmCheckGuards :: [GrdVec] -> Int -> Delta -> DsM PartialResult-pmCheckGuards []       _ delta = return (usimple delta)-pmCheckGuards (gv:gvs) n delta = do-  dflags <- getDynFlags-  let limit = maxPmCheckModels dflags `div` 5-  (n', PartialResult cs unc ds pc) <- throttle limit (pmCheck gv []) n delta-  (PartialResult css uncs dss pcs) <- runMany (pmCheckGuards gvs n') unc-  return $ PartialResult (cs `mappend` css)-                         uncs-                         (ds `mappend` dss)-                         (pc `mappend` pcs)---- | Matching function: Check simultaneously a clause (takes separately the--- patterns and the list of guards) for exhaustiveness, redundancy and--- inaccessibility.-pmCheck'-  :: GrdVec   -- ^ Patterns of the clause-  -> [GrdVec] -- ^ (Possibly multiple) guards of the clause-  -> Int      -- ^ Estimate on the number of similar 'Delta's to handle.-              --   See 6. in Note [Countering exponential blowup]-  -> Delta    -- ^ Oracle state giving meaning to the identifiers in the ValVec-  -> DsM PartialResult-pmCheck' [] guards n delta-  | null guards = return $ mempty { presultCovered = Covered }-  | otherwise   = pmCheckGuards guards n delta---- let x = e: Add x ~ e to the oracle-pmCheck' (PmLet { pm_id = x, pm_let_expr = e } : ps) guards n delta = do-  tracePm "PmLet" (vcat [ppr x, ppr e])-  -- x is fresh because it's bound by the let-  delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e-  pmCheck ps guards n delta'---- Bang x: Add x /~ _|_ to the oracle-pmCheck' (PmBang x : ps) guards n delta = do-  tracePm "PmBang" (ppr x)-  pr <- pmCheckM ps guards n (addTmCt delta (TmVarNonVoid x))-  pure (forceIfCanDiverge delta x pr)---- Con: Add x ~ K ys to the Covered set and x /~ K to the Uncovered set-pmCheck' (p : ps) guards n delta-  | PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args-         , pm_con_dicts = dicts } <- p = do-  -- E.g   f (K p q) = <rhs>-  --       <next equation>-  -- Split delta into two refinements:-  --    * one for <rhs>, binding x to (K p q)-  --    * one for <next equation>, recording that x is /not/ (K _ _)--  -- Stuff for <rhs>-  pr_pos <- pmCheckM ps guards n (addPmConCts delta x con dicts args)--  -- The var is forced regardless of whether @con@ was satisfiable-  -- See Note [Divergence of Newtype matches]-  let pr_pos' = addConMatchStrictness delta x con pr_pos--  -- Stuff for <next equation>-  pr_neg <- addRefutableAltCon delta x con >>= \case-    Nothing     -> pure mempty-    Just delta' -> pure (usimple delta')--  tracePm "PmCon" (vcat [ppr p, ppr x, ppr pr_pos', ppr pr_neg])--  -- Combine both into a single PartialResult-  let pr = mkUnion pr_pos' pr_neg-  pure pr--addPmConCts :: Delta -> Id -> PmAltCon -> [EvVar] -> [Id] -> DsM (Maybe Delta)-addPmConCts delta x con dicts fields = runMaybeT $ do-  delta_ty    <- MaybeT $ addTypeEvidence delta (listToBag dicts)-  delta_tm_ty <- MaybeT $ addTmCt delta_ty (TmVarCon x con fields)-  pure delta_tm_ty- -- ------------------------------------------------------------------------------- * Utilities for main checking---- | Initialise with default values for covering and divergent information and--- a singleton uncovered set.-usimple :: Delta -> PartialResult-usimple delta = mempty { presultUncovered = [delta] }---- | Get the union of two covered, uncovered and divergent value set--- abstractions. Since the covered and divergent sets are represented by a--- boolean, union means computing the logical or (at least one of the two is--- non-empty).--mkUnion :: PartialResult -> PartialResult -> PartialResult-mkUnion = mappend---- | Set the divergent set to not empty-forces :: PartialResult -> PartialResult-forces pres = pres { presultDivergent = Diverged }---- | Set the divergent set to non-empty if the variable has not been forced yet-forceIfCanDiverge :: Delta -> Id -> PartialResult -> PartialResult-forceIfCanDiverge delta x-  | canDiverge delta x = forces-  | otherwise          = id---- | 'forceIfCanDiverge' if the 'PmAltCon' was not a Newtype.--- See Note [Divergence of Newtype matches].-addConMatchStrictness :: Delta -> Id -> PmAltCon -> PartialResult -> PartialResult-addConMatchStrictness _     _ (PmAltConLike (RealDataCon dc)) res-  | isNewTyCon (dataConTyCon dc) = res-addConMatchStrictness delta x _ res = forceIfCanDiverge delta x res---- ---------------------------------------------------------------------------- -- * Propagation of term constraints inwards when checking nested matches  {- Note [Type and Term Equality Propagation]@@ -1158,7 +1020,7 @@ -- | Add in-scope type constraints addTyCsDs :: Bag EvVar -> DsM a -> DsM a addTyCsDs ev_vars =-  locallyExtendPmDelta (\delta -> addTypeEvidence delta ev_vars)+  locallyExtendPmDelta (\delta -> addPmCts delta (PmTyCt . evVarPred <$> ev_vars))  -- | Add equalities for the scrutinee to the local 'DsM' environment when -- checking a case expression:@@ -1169,9 +1031,15 @@ addScrutTmCs Nothing    _   k = k addScrutTmCs (Just scr) [x] k = do   scr_e <- dsLExpr scr-  locallyExtendPmDelta (\delta -> addVarCoreCt delta x scr_e) k+  locallyExtendPmDelta (\delta -> addPmCts delta (unitBag (PmCoreCt x scr_e))) k addScrutTmCs _   _   _ = panic "addScrutTmCs: HsCase with more than one case binder" +addPmConCts :: Delta -> Id -> PmAltCon -> [TyVar] -> [EvVar] -> [Id] -> DsM (Maybe Delta)+addPmConCts delta x con tvs dicts fields = runMaybeT $ do+  delta_ty    <- MaybeT $ addPmCts delta (listToBag (PmTyCt . evVarPred <$> dicts))+  delta_tm_ty <- MaybeT $ addPmCts delta_ty (unitBag (PmConCt x con tvs fields))+  pure delta_tm_ty+ -- | Add equalities to the local 'DsM' environment when checking the RHS of a -- case expression: --     case e of x { p1 -> e1; ... pn -> en }@@ -1197,14 +1065,14 @@ -- ConVar case harder to understand. computeCovered [] delta = pure (Just delta) computeCovered (PmLet { pm_id = x, pm_let_expr = e } : ps) delta = do-  delta' <- expectJust "x is fresh" <$> addVarCoreCt delta x e+  delta' <- expectJust "x is fresh" <$> addPmCts delta (unitBag (PmCoreCt x e))   computeCovered ps delta' computeCovered (PmBang{} : ps) delta = do   computeCovered ps delta computeCovered (p : ps) delta-  | PmCon{ pm_id = x, pm_con_con = con, pm_con_args = args+  | PmCon{ pm_id = x, pm_con_con = con, pm_con_tvs = tvs, pm_con_args = args          , pm_con_dicts = dicts } <- p-  = addPmConCts delta x con dicts args >>= \case+  = addPmConCts delta x con tvs dicts args >>= \case       Nothing     -> pure Nothing       Just delta' -> computeCovered ps delta' @@ -1235,13 +1103,65 @@   | otherwise   = notNull (filter (`wopt` dflags) allPmCheckWarnings) +redundantAndInaccessibleRhss :: AnnotatedTree -> ([RhsInfo], [RhsInfo])+redundantAndInaccessibleRhss tree = (fromOL ol_red, fromOL ol_inacc)+  where+    (_ol_acc, ol_inacc, ol_red) = go tree+    -- | Collects RHSs which are+    --    1. accessible+    --    2. proper inaccessible (so we can't delete them)+    --    3. hypothetically redundant (so not only inaccessible RHS, but we can+    --       even safely delete the equation without altering semantics)+    -- See Note [Determining inaccessible clauses]+    go :: AnnotatedTree -> (OrdList RhsInfo, OrdList RhsInfo, OrdList RhsInfo)+    go (AccessibleRhs info)   = (unitOL info, nilOL, nilOL)+    go (InaccessibleRhs info) = (nilOL,       nilOL, unitOL info) -- presumably redundant+    go (MayDiverge t)         = case go t of+      -- See Note [Determining inaccessible clauses]+      (acc, inacc, red)+        | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL)+      res                              -> res+    go (SequenceAnn l r)      = go l Semi.<> go r+    go EmptyAnn               = (nilOL,       nilOL, nilOL)++{- Note [Determining inaccessible clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f _  True = ()+  f () True = ()+  f _  _    = ()+Is f's second clause redundant? The perhaps surprising answer is, no, it isn't!+@f (error "boom") False@ will force the error with clause 2, but will return+() if it was deleted, so clearly not redundant. Yet for now combination of+arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS+(as opposed to being completely redundant).++We detect an inaccessible RHS simply by pretending it's redundant, until we see+that it's part of a sub-tree in the pattern match that forces some argument+(which corresponds to wrapping the 'AnnotatedTree' in 'MayDiverge'). Then we+turn all supposedly redundant RHSs into inaccessible ones.++But as it turns out (@g@ from #17465) this is too conservative:+  g () | False = ()+       | otherwise = ()+g's first clause has an inaccessible RHS, but it's also safe to delete. So it's+redundant, really! But by just turning all redundant child clauses into+inaccessible ones, we report the first clause as inaccessible.++Clearly, it is enough if we say that we only degrade if *not all* of the child+clauses are redundant. As long as there is at least one clause which we announce+not to be redundant, the guard prefix responsible for the 'MayDiverge' will+survive. Hence we check for that in 'redundantAndInaccessibleRhss'.+-}+ -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)-dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> PmResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result+dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> CheckResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result   = when (flag_i || flag_u) $ do+      unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered       let exists_r = flag_i && notNull redundant           exists_i = flag_i && notNull inaccessible && not is_rec_upd-          exists_u = flag_u && notNull uncovered+          exists_u = flag_u && notNull unc_examples           approx   = precision == Approximate        when (approx && (exists_u || exists_i)) $@@ -1253,14 +1173,15 @@       when exists_i $ forM_ inaccessible $ \(L l q) -> do         putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)                                (pprEqn q "has inaccessible right hand side"))+       when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $-        pprEqns vars uncovered+        pprEqns vars unc_examples   where-    PmResult-      { pmresultRedundant = redundant-      , pmresultUncovered = uncovered-      , pmresultInaccessible = inaccessible-      , pmresultApproximate = precision } = pm_result+    CheckResult+      { cr_clauses = clauses+      , cr_uncov   = uncovered+      , cr_approx  = precision } = result+    (redundant, inaccessible) = redundantAndInaccessibleRhss clauses      flag_i = wopt Opt_WarnOverlappingPatterns dflags     flag_u = exhaustive dflags kind@@ -1273,7 +1194,7 @@      -- Print a single clause (for redundant/with-inaccessible-rhs)     pprEqn q txt = pprContext True ctx (text txt) $ \f ->-      f (pprPats kind (map unLoc q))+      f (q <+> matchSeparator kind <+> text "...")      -- Print several clauses (for uncovered clauses)     pprEqns vars deltas = pprContext False ctx (text "are non-exhaustive") $ \_ ->@@ -1294,6 +1215,16 @@           $$ bullet <+> text "Patterns reported as unmatched might actually be matched")       , text "Increase the limit or resolve the warnings to suppress this message." ] +getNFirstUncovered :: [Id] -> Int -> Deltas -> DsM [Delta]+getNFirstUncovered vars n (MkDeltas deltas) = go n (bagToList deltas)+  where+    go 0 _              = pure []+    go _ []             = pure []+    go n (delta:deltas) = do+      front <- provideEvidence vars n delta+      back <- go (n - length front) deltas+      pure (front ++ back)+ {- Note [Inaccessible warnings for record updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#12957)@@ -1369,7 +1300,3 @@              FunRhs { mc_fun = L _ fun }                   -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)              _    -> (pprMatchContext kind, \ pp -> pp)--pprPats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc-pprPats kind pats-  = sep [sep (map ppr pats), matchSeparator kind, text "..."]
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -7,21 +7,20 @@ {-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns, MultiWayIf #-}  -- | The pattern match oracle. The main export of the module are the functions--- 'addTmCt', 'addVarCoreCt', 'addRefutableAltCon' and 'addTypeEvidence' for--- adding facts to the oracle, and 'provideEvidence' to turn a+-- 'addPmCts' for adding facts to the oracle, and 'provideEvidence' to turn a -- 'Delta' into a concrete evidence for an equation. module GHC.HsToCore.PmCheck.Oracle (          DsM, tracePm, mkPmId,         Delta, initDelta, lookupRefuts, lookupSolution, -        TmCt(..),-        addTypeEvidence,    -- Add type equalities-        addRefutableAltCon, -- Add a negative term equality-        addTmCt,            -- Add a positive term equality x ~ e-        addVarCoreCt,       -- Add a positive term equality x ~ core_expr+        PmCt(PmTyCt), PmCts, pattern PmVarCt, pattern PmCoreCt,+        pattern PmConCt, pattern PmNotConCt, pattern PmBotCt,+        pattern PmNotBotCt,++        addPmCts,           -- Add a constraint to the oracle.         canDiverge,         -- Try to add the term equality x ~ ⊥-        provideEvidence,+        provideEvidence     ) where  #include "HsVersions.h"@@ -63,7 +62,6 @@ import TyCoRep import Type import TcSimplify    (tcNormalise, tcCheckSatisfiability)-import TcType        (evVarPred) import Unify         (tcMatchTy) import TcRnTypes     (completeMatchConLikes) import Coercion@@ -72,18 +70,19 @@ import FamInst import FamInstEnv -import Control.Monad (guard, mzero)+import Control.Monad (guard, mzero, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.Bifunctor (second)-import Data.Foldable (foldlM, minimumBy)+import Data.Either   (partitionEithers)+import Data.Foldable (foldlM, minimumBy, toList) import Data.List     (find) import qualified Data.List.NonEmpty as NonEmpty import Data.Ord      (comparing) import qualified Data.Semigroup as Semigroup import Data.Tuple    (swap) --- Debugging Infrastructre+-- Debugging Infrastructure  tracePm :: String -> SDoc -> DsM () tracePm herald doc = do@@ -113,9 +112,9 @@  -- | Instantiate a 'ConLike' given its universal type arguments. Instantiates -- existential and term binders with fresh variables of appropriate type.--- Returns instantiated term variables from the match, type evidence and the--- types of strict constructor fields.-mkOneConFull :: [Type] -> ConLike -> DsM ([Id], Bag TyCt, [Type])+-- Returns instantiated type and term variables from the match, type evidence+-- and the types of strict constructor fields.+mkOneConFull :: [Type] -> ConLike -> DsM ([TyVar], [Id], Bag TyCt, [Type]) --  * 'con' K is a ConLike --       - In the case of DataCons and most PatSynCons, these --         are associated with a particular TyCon T@@ -133,16 +132,17 @@ -- be a concrete TyCon. -- -- Suppose y1 is a strict field. Then we get--- Results: [y1,..,yn]+-- Results: bs+--          [y1,..,yn] --          Q --          [s1] mkOneConFull arg_tys con = do-  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , field_tys, _con_res_ty)+  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty)         = conLikeFullSig con   -- pprTrace "mkOneConFull" (ppr con $$ ppr arg_tys $$ ppr univ_tvs $$ ppr _con_res_ty) (return ())   -- Substitute universals for type arguments   let subst_univ = zipTvSubst univ_tvs arg_tys-  -- Instantiate fresh existentials as arguments to the contructor. This is+  -- Instantiate fresh existentials as arguments to the constructor. This is   -- important for instantiating the Thetas and field types.   (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM   let field_tys' = substTys subst field_tys@@ -150,7 +150,7 @@   vars <- mapM mkPmId field_tys'   -- All constraints bound by the constructor (alpha-renamed), these are added   -- to the type oracle-  let ty_cs = map TyCt (substTheta subst (eqSpecPreds eq_spec ++ thetas))+  let ty_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)   -- Figure out the types of strict constructor fields   let arg_is_strict         | RealDataCon dc <- con@@ -159,7 +159,7 @@         | otherwise         = map isBanged $ conLikeImplBangs con       strict_arg_tys = filterByList arg_is_strict field_tys'-  return (vars, listToBag ty_cs, strict_arg_tys)+  return (ex_tvs, vars, listToBag ty_cs, strict_arg_tys)  ------------------------- -- * Pattern match oracle@@ -175,7 +175,7 @@ We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC used not to do this; in fact, it would warn that the match was /redundant/! This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the-coverage checker deems any matches with unsatifiable constraint sets to be+coverage checker deems any matches with unsatisfiable constraint sets to be unreachable.  We decide to better than this. When beginning coverage checking, we first@@ -233,14 +233,14 @@ pmIsSatisfiable   :: Delta       -- ^ The ambient term and type constraints                  --   (known to be satisfiable).-  -> Bag TmCt    -- ^ The new term constraints.   -> Bag TyCt    -- ^ The new type constraints.+  -> Bag TmCt    -- ^ The new term constraints.   -> [Type]      -- ^ The strict argument types.   -> DsM (Maybe Delta)                  -- ^ @'Just' delta@ if the constraints (@delta@) are                  -- satisfiable, and each strict argument type is inhabitable.                  -- 'Nothing' otherwise.-pmIsSatisfiable amb_cs new_tm_cs new_ty_cs strict_arg_tys =+pmIsSatisfiable amb_cs new_ty_cs new_tm_cs strict_arg_tys =   -- The order is important here! Check the new type constraints before we check   -- whether strict argument types are inhabited given those constraints.   runSatisfiabilityCheck amb_cs $ mconcat@@ -495,16 +495,9 @@ ---------------- -- * Type oracle --- | Wraps a 'PredType', which is a constraint type.-newtype TyCt = TyCt PredType--instance Outputable TyCt where-  ppr (TyCt pred_ty) = ppr pred_ty---- | Allocates a fresh 'EvVar' name for 'PredTyCt's, or simply returns the--- wrapped 'EvVar' for 'EvVarTyCt's.-nameTyCt :: TyCt -> DsM EvVar-nameTyCt (TyCt pred_ty) = do+-- | Allocates a fresh 'EvVar' name for 'PredTy's.+nameTyCt :: PredType -> DsM EvVar+nameTyCt pred_ty = do   unique <- getUniqueM   let occname = mkVarOccFS (fsLit ("pm_"++show unique))       idname  = mkInternalName unique occname noSrcSpan@@ -512,15 +505,13 @@  -- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we -- find a contradiction (e.g. @Int ~ Bool@).-tyOracle :: TyState -> Bag TyCt -> DsM (Maybe TyState)+tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState) tyOracle (TySt inert) cts   = do { evs <- traverse nameTyCt cts        ; let new_inert = inert `unionBags` evs        ; tracePm "tyOracle" (ppr cts)        ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability new_inert        ; case res of-            -- Note how this implicitly gives all former PredTyCts a name, so-            -- that we don't needlessly re-allocate them every time!             Just True  -> return (Just (TySt new_inert))             Just False -> return Nothing             Nothing    -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }@@ -530,7 +521,7 @@ -- ones. Doesn't bother calling out to the type oracle if the bag of new type -- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle -- for emptiness if the first argument is 'True'.-tyIsSatisfiable :: Bool -> Bag TyCt -> SatisfiabilityCheck+tyIsSatisfiable :: Bool -> Bag PredType -> SatisfiabilityCheck tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta ->   if isEmptyBag new_ty_cs     then pure (Just delta)@@ -562,7 +553,7 @@ Invariant applying to each VarInfo: Whenever we have @(C, [y,z])@ in 'vi_pos', any entry in 'vi_neg' must be incomparable to C (return Nothing) according to 'eqPmAltCons'. Those entries that are comparable either lead to a refutation-or are redudant. Examples:+or are redundant. Examples: * @x ~ Just y@, @x /~ [Just]@. 'eqPmAltCon' returns @Equal@, so refute. * @x ~ Nothing@, @x /~ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative   info is redundant and should be discarded.@@ -658,9 +649,7 @@ -- Returns a new 'Delta' if the new constraints are compatible with existing -- ones. tmIsSatisfiable :: Bag TmCt -> SatisfiabilityCheck-tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM go delta new_tm_cs-  where-    go delta ct = MaybeT (addTmCt delta ct)+tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM addTmCt delta new_tm_cs  ----------------------- -- * Looking up VarInfo@@ -767,7 +756,7 @@   | VI _ pos neg _ <- lookupVarInfo ts x   = null neg && all pos_can_diverge pos   where-    pos_can_diverge (PmAltConLike (RealDataCon dc), [y])+    pos_can_diverge (PmAltConLike (RealDataCon dc), _, [y])       -- See Note [Divergence of Newtype matches]       | isNewTyCon (dataConTyCon dc) = canDiverge delta y     pos_can_diverge _ = False@@ -789,8 +778,8 @@  If we treat Newtypes like we treat regular DataCons, we would mark the third clause as redundant, which clearly is unsound. The solution:-1. When checking the PmCon in 'pmCheck', never mark the result as Divergent if-   it's a Newtype match.+1. When compiling the PmCon guard in 'pmCompileTree', don't add a @DivergeIf@,+   because the match will never diverge. 2. Regard @T2 x@ as 'canDiverge' iff @x@ 'canDiverge'. E.g. @T2 x ~ _|_@ <=>    @x ~ _|_@. This way, the third clause will still be marked as inaccessible    RHS instead of redundant.@@ -807,13 +796,13 @@     Just (Indirect y) -> vi_neg (lookupVarInfo ts y)     Just (Entry vi)   -> vi_neg vi -isDataConSolution :: (PmAltCon, [Id]) -> Bool-isDataConSolution (PmAltConLike (RealDataCon _), _) = True-isDataConSolution _                                 = False+isDataConSolution :: (PmAltCon, [TyVar], [Id]) -> Bool+isDataConSolution (PmAltConLike (RealDataCon _), _, _) = True+isDataConSolution _                                    = False  -- @lookupSolution delta x@ picks a single solution ('vi_pos') of @x@ from -- possibly many, preferring 'RealDataCon' solutions whenever possible.-lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [Id])+lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [TyVar], [Id]) lookupSolution delta x = case vi_pos (lookupVarInfo (delta_tm_st delta) x) of   []                                         -> Nothing   pos@@ -823,43 +812,111 @@ ------------------------------- -- * Adding facts to the oracle --- | A term constraint. Either equates two variables or a variable with a--- 'PmAltCon' application.+-- | A term constraint. data TmCt-  = TmVarVar     !Id !Id-  | TmVarCon     !Id !PmAltCon ![Id]-  | TmVarNonVoid !Id+  = TmVarCt     !Id !Id+  -- ^ @TmVarCt x y@ encodes "x ~ y", equating @x@ and @y@.+  | TmCoreCt    !Id !CoreExpr+  -- ^ @TmCoreCt x e@ encodes "x ~ e", equating @x@ with the 'CoreExpr' @e@.+  | TmConCt     !Id !PmAltCon ![TyVar] ![Id]+  -- ^ @TmConCt x K tvs ys@ encodes "x ~ K @tvs ys", equating @x@ with the 'PmAltCon'+  -- application @K @tvs ys@.+  | TmNotConCt  !Id !PmAltCon+  -- ^ @TmNotConCt x K@ encodes "x /~ K", asserting that @x@ can't be headed+  -- by @K@.+  | TmBotCt     !Id+  -- ^ @TmBotCt x@ encodes "x ~ ⊥", equating @x@ to ⊥.+  -- by @K@.+  | TmNotBotCt !Id+  -- ^ @TmNotBotCt x y@ encodes "x /~ ⊥", asserting that @x@ can't be ⊥.  instance Outputable TmCt where-  ppr (TmVarVar x y)        = ppr x <+> char '~' <+> ppr y-  ppr (TmVarCon x con args) = ppr x <+> char '~' <+> hsep (ppr con : map ppr args)-  ppr (TmVarNonVoid x)      = ppr x <+> text "/~ ⊥"+  ppr (TmVarCt x y)            = ppr x <+> char '~' <+> ppr y+  ppr (TmCoreCt x e)           = ppr x <+> char '~' <+> ppr e+  ppr (TmConCt x con tvs args) = ppr x <+> char '~' <+> hsep (ppr con : pp_tvs ++ pp_args)+    where+      pp_tvs  = map ((<> char '@') . ppr) tvs+      pp_args = map ppr args+  ppr (TmNotConCt x con)       = ppr x <+> text "/~" <+> ppr con+  ppr (TmBotCt x)              = ppr x <+> text "~ ⊥"+  ppr (TmNotBotCt x)           = ppr x <+> text "/~ ⊥" --- | Add type equalities to 'Delta'.-addTypeEvidence :: Delta -> Bag EvVar -> DsM (Maybe Delta)-addTypeEvidence delta dicts-  = runSatisfiabilityCheck delta (tyIsSatisfiable True (TyCt . evVarPred <$> dicts))+type TyCt = PredType --- | Tries to equate two representatives in 'Delta'.+-- | An oracle constraint.+data PmCt+  = PmTyCt !TyCt+  -- ^ @PmTy pred_ty@ carries 'PredType's, for example equality constraints.+  | PmTmCt !TmCt+  -- ^ A term constraint.++type PmCts = Bag PmCt++pattern PmVarCt :: Id -> Id -> PmCt+pattern PmVarCt x y            = PmTmCt (TmVarCt x y)+pattern PmCoreCt :: Id -> CoreExpr -> PmCt+pattern PmCoreCt x e           = PmTmCt (TmCoreCt x e)+pattern PmConCt :: Id -> PmAltCon -> [TyVar] -> [Id] -> PmCt+pattern PmConCt x con tvs args = PmTmCt (TmConCt x con tvs args)+pattern PmNotConCt :: Id -> PmAltCon -> PmCt+pattern PmNotConCt x con       = PmTmCt (TmNotConCt x con)+pattern PmBotCt :: Id -> PmCt+pattern PmBotCt x              = PmTmCt (TmBotCt x)+pattern PmNotBotCt :: Id -> PmCt+pattern PmNotBotCt x           = PmTmCt (TmNotBotCt x)+{-# COMPLETE PmTyCt, PmVarCt, PmCoreCt, PmConCt, PmNotConCt, PmBotCt, PmNotBotCt #-}++instance Outputable PmCt where+  ppr (PmTyCt pred_ty) = ppr pred_ty+  ppr (PmTmCt tm_ct)   = ppr tm_ct++-- | Adds new constraints to 'Delta' and returns 'Nothing' if that leads to a+-- contradiction.+addPmCts :: Delta -> PmCts -> DsM (Maybe Delta) -- See Note [TmState invariants].-addTmCt :: Delta -> TmCt -> DsM (Maybe Delta)-addTmCt delta ct = runMaybeT $ case ct of-  TmVarVar x y        -> addVarVarCt delta (x, y)-  TmVarCon x con args -> addVarConCt delta x con args-  TmVarNonVoid x      -> addVarNonVoidCt delta x+addPmCts delta cts = do+  let (ty_cts, tm_cts) = partitionTyTmCts cts+  runSatisfiabilityCheck delta $ mconcat+    [ tyIsSatisfiable True (listToBag ty_cts)+    , tmIsSatisfiable (listToBag tm_cts)+    ] +partitionTyTmCts :: PmCts -> ([TyCt], [TmCt])+partitionTyTmCts = partitionEithers . map to_either . toList+  where+    to_either (PmTyCt pred_ty) = Left pred_ty+    to_either (PmTmCt tm_ct)   = Right tm_ct++-- | Adds a single term constraint by dispatching to the various term oracle+-- functions.+addTmCt :: Delta -> TmCt -> MaybeT DsM Delta+addTmCt delta (TmVarCt x y)            = addVarVarCt delta (x, y)+addTmCt delta (TmCoreCt x e)           = addVarCoreCt delta x e+addTmCt delta (TmConCt x con tvs args) = addVarConCt delta x con tvs args+addTmCt delta (TmNotConCt x con)       = addRefutableAltCon delta x con+addTmCt delta (TmBotCt x)              = addVarBotCt delta x+addTmCt delta (TmNotBotCt x)           = addVarNonVoidCt delta x++-- | In some future this will actually add a constraint to 'Delta' that we plan+-- to preserve. But for now, we just check if we can add the constraint to the+-- current 'Delta'. If so, we return the original 'Delta', if not, we fail.+addVarBotCt :: Delta -> Id -> MaybeT DsM Delta+addVarBotCt delta x+  | canDiverge delta x = pure delta+  | otherwise          = mzero+ -- | Record that a particular 'Id' can't take the shape of a 'PmAltCon' in the -- 'Delta' and return @Nothing@ if that leads to a contradiction. -- See Note [TmState invariants].-addRefutableAltCon :: Delta -> Id -> PmAltCon -> DsM (Maybe Delta)-addRefutableAltCon delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = runMaybeT $ do+addRefutableAltCon :: Delta -> Id -> PmAltCon -> MaybeT DsM Delta+addRefutableAltCon delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = do   vi@(VI _ pos neg pm) <- lift (initLookupVarInfo delta x)   -- 1. Bail out quickly when nalt contradicts a solution-  let contradicts nalt (cl, _args) = eqPmAltCon cl nalt == Equal+  let contradicts nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Equal   guard (not (any (contradicts nalt) pos))   -- 2. Only record the new fact when it's not already implied by one of the   -- solutions-  let implies nalt (cl, _args) = eqPmAltCon cl nalt == Disjoint+  let implies nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Disjoint   let neg'         | any (implies nalt) pos = neg         -- See Note [Completeness checking with required Thetas]@@ -934,7 +991,7 @@   subst <- tcMatchTy con_res_ty res_ty   traverse (lookupTyVar subst) univ_tvs --- | Kind of tries to add a non-void contraint to 'Delta', but doesn't really+-- | Kind of tries to add a non-void constraint to 'Delta', but doesn't really -- commit to upholding that constraint in the future. This will be rectified -- in a follow-up patch. The status quo should work good enough for now. addVarNonVoidCt :: Delta -> Id -> MaybeT DsM Delta@@ -984,7 +1041,7 @@       case guessConLikeUnivTyArgsFromResTy env (vi_ty vi) con of         Nothing -> pure True -- be conservative about this         Just arg_tys -> do-          (_vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con+          (_tvs, _vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con           tracePm "inh_test" (ppr con $$ ppr ty_cs)           -- No need to run the term oracle compared to pmIsSatisfiable           fmap isJust <$> runSatisfiabilityCheck delta $ mconcat@@ -1049,10 +1106,10 @@         let env_refs = setEntrySDIE env_ind y vi_y         let delta_refs = delta{ delta_tm_st = TmSt env_refs reps }         -- and then gradually merge every positive fact we have on x into y-        let add_fact delta (cl, args) = addVarConCt delta y cl args+        let add_fact delta (cl, tvs, args) = addVarConCt delta y cl tvs args         delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x)         -- Do the same for negative info-        let add_refut delta nalt = MaybeT (addRefutableAltCon delta y nalt)+        let add_refut delta nalt = addRefutableAltCon delta y nalt         delta_neg <- foldlM add_refut delta_pos (vi_neg vi_x)         -- vi_cache will be updated in addRefutableAltCon, so we are good to         -- go!@@ -1063,27 +1120,40 @@ -- other solutions, reject (@Nothing@) otherwise. -- -- See Note [TmState invariants].-addVarConCt :: Delta -> Id -> PmAltCon -> [Id] -> MaybeT DsM Delta-addVarConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt args = do+addVarConCt :: Delta -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Delta+addVarConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt tvs args = do   VI ty pos neg cache <- lift (initLookupVarInfo delta x)   -- First try to refute with a negative fact   guard (all ((/= Equal) . eqPmAltCon alt) neg)   -- Then see if any of the other solutions (remember: each of them is an   -- additional refinement of the possible values x could take) indicate a   -- contradiction-  guard (all ((/= Disjoint) . eqPmAltCon alt . fst) pos)-  -- Now we should be good! Add (alt, args) as a possible solution, or refine an-  -- existing one-  case find ((== Equal) . eqPmAltCon alt . fst) pos of-    Just (_, other_args) -> do-      foldlM addVarVarCt delta (zip args other_args)+  guard (all ((/= Disjoint) . eqPmAltCon alt . fstOf3) pos)+  -- Now we should be good! Add (alt, tvs, args) as a possible solution, or+  -- refine an existing one+  case find ((== Equal) . eqPmAltCon alt . fstOf3) pos of+    Just (_con, other_tvs, other_args) -> do+      -- We must unify existentially bound ty vars and arguments!+      let ty_cts = equateTyVarsCts tvs other_tvs+      when (length args /= length other_args) $+        lift $ tracePm "error" (ppr x <+> ppr alt <+> ppr args <+> ppr other_args)+      let tm_cts = zipWithEqual "addVarConCt" PmVarCt args other_args+      MaybeT $ addPmCts delta (listToBag ty_cts `unionBags` listToBag tm_cts)     Nothing -> do       -- Filter out redundant negative facts (those that compare Just False to       -- the new solution)       let neg' = filter ((== PossiblyOverlap) . eqPmAltCon alt) neg-      let pos' = (alt,args):pos+      let pos' = (alt, tvs, args):pos       pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg' cache)) reps} +equateTyVarsCts :: [TyVar] -> [TyVar] -> [PmCt]+equateTyVarsCts as bs+  = map (\(a, b) -> PmTyCt $ mkPrimEqPred (mkTyVarTy a) (mkTyVarTy b))+  -- The following line filters out trivial Refl constraints, so that we don't+  -- need to initialise the type oracle that often+  $ filter (uncurry (/=))+  $ zipEqual "equateTyVarsCts" as bs+ ---------------------------------------- -- * Enumerating inhabitation candidates @@ -1095,16 +1165,14 @@ -- See @Note [Strict argument type constraints]@. data InhabitationCandidate =   InhabitationCandidate-  { ic_tm_cs          :: Bag TmCt-  , ic_ty_cs          :: Bag TyCt+  { ic_cs             :: PmCts   , ic_strict_arg_tys :: [Type]   }  instance Outputable InhabitationCandidate where-  ppr (InhabitationCandidate tm_cs ty_cs strict_arg_tys) =+  ppr (InhabitationCandidate cs strict_arg_tys) =     text "InhabitationCandidate" <+>-      vcat [ text "ic_tm_cs          =" <+> ppr tm_cs-           , text "ic_ty_cs          =" <+> ppr ty_cs+      vcat [ text "ic_cs             =" <+> ppr cs            , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]  mkInhabitationCandidate :: Id -> DataCon -> DsM InhabitationCandidate@@ -1112,10 +1180,9 @@ mkInhabitationCandidate x dc = do   let cl = RealDataCon dc   let tc_args = tyConAppArgs (idType x)-  (arg_vars, ty_cs, strict_arg_tys) <- mkOneConFull tc_args cl+  (ty_vars, arg_vars, ty_cs, strict_arg_tys) <- mkOneConFull tc_args cl   pure InhabitationCandidate-        { ic_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars)-        , ic_ty_cs = ty_cs+        { ic_cs = PmTyCt <$> ty_cs `snocBag` PmConCt x (PmAltConLike cl) ty_vars arg_vars         , ic_strict_arg_tys = strict_arg_tys         } @@ -1133,13 +1200,15 @@     NormalisedByConstraints ty'   -> alts_to_check ty'    ty'     []     HadRedexes src_ty dcs core_ty -> alts_to_check src_ty core_ty dcs   where-    build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, TmCt)+    build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, PmCt)     build_newtype (ty, dc, _arg_ty) x = do       -- ty is the type of @dc x@. It's a @dataConTyCon dc@ application.       y <- mkPmId ty-      pure (y, TmVarCon y (PmAltConLike (RealDataCon dc)) [x])+      -- Newtypes don't have existentials (yet?!), so passing an empty list as+      -- ex_tvs.+      pure (y, PmConCt y (PmAltConLike (RealDataCon dc)) [] [x]) -    build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [TmCt])+    build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [PmCt])     build_newtypes x = foldrM (\dc (x, cts) -> go dc x cts) (x, [])       where         go dc x cts = second (:cts) <$> build_newtype dc x@@ -1155,8 +1224,8 @@              (_:_) -> do inner <- mkPmId core_ty                          (outer, new_tm_cts) <- build_newtypes inner dcs                          return $ Right (tc, outer, [InhabitationCandidate-                           { ic_tm_cs = listToBag new_tm_cts-                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])+                           { ic_cs = listToBag new_tm_cts+                           , ic_strict_arg_tys = [] }])          |  pmIsClosedType core_ty && not (isAbstractTyCon tc)            -- Don't consider abstract tycons since we don't know what their@@ -1165,8 +1234,8 @@         -> do              inner <- mkPmId core_ty -- it would be wrong to unify inner              alts <- mapM (mkInhabitationCandidate inner) (tyConDataCons tc)-             (outer, new_tm_cts) <- build_newtypes inner dcs-             let wrap_dcs alt = alt{ ic_tm_cs = listToBag new_tm_cts `unionBags` ic_tm_cs alt}+             (outer, new_cts) <- build_newtypes inner dcs+             let wrap_dcs alt = alt{ ic_cs = listToBag new_cts `unionBags` ic_cs alt}              return $ Right (tc, outer, map wrap_dcs alts)       -- For other types conservatively assume that they are inhabited.       _other -> return (Left src_ty)@@ -1278,12 +1347,12 @@     cand_is_inhabitable :: RecTcChecker -> Delta                         -> InhabitationCandidate -> DsM Bool     cand_is_inhabitable rec_ts amb_cs-      (InhabitationCandidate{ ic_tm_cs          = new_tm_cs-                            , ic_ty_cs          = new_ty_cs-                            , ic_strict_arg_tys = new_strict_arg_tys }) =+      (InhabitationCandidate{ ic_cs             = new_cs+                            , ic_strict_arg_tys = new_strict_arg_tys }) = do+        let (new_ty_cs, new_tm_cs) = partitionTyTmCts new_cs         fmap isJust $ runSatisfiabilityCheck amb_cs $ mconcat-          [ tyIsSatisfiable False new_ty_cs-          , tmIsSatisfiable new_tm_cs+          [ tyIsSatisfiable False (listToBag new_ty_cs)+          , tmIsSatisfiable (listToBag new_tm_cs)           , tysAreNonVoid rec_ts new_strict_arg_tys           ] @@ -1340,7 +1409,7 @@  `nonVoid ty` returns True when either: 1. `ty` has at least one InhabitationCandidate for which both its term and type-   constraints are satifiable, and `nonVoid` returns `True` for all of the+   constraints are satisfiable, and `nonVoid` returns `True` for all of the    strict argument types in that InhabitationCandidate. 2. We're unsure if it's inhabited by a terminating value. @@ -1458,7 +1527,7 @@           -- where @x@ will have two possibly compatible solutions, @Just y@ for           -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@           -- and @z@ that is valid at the same time. These constitute arg_vas below.-          let arg_vas = concatMap (\(_cl, args) -> args) pos+          let arg_vas = concatMap (\(_cl, _tvs, args) -> args) pos           go (arg_vas ++ xs) n delta         []           -- When there are literals involved, just print negative info@@ -1476,7 +1545,9 @@       (_src_ty, dcs, core_ty) <- tntrGuts <$> pmTopNormaliseType (delta_ty_st delta) (idType x)       let build_newtype (x, delta) (_ty, dc, arg_ty) = do             y <- lift $ mkPmId arg_ty-            delta' <- addVarConCt delta x (PmAltConLike (RealDataCon dc)) [y]+            -- Newtypes don't have existentials (yet?!), so passing an empty+            -- list as ex_tvs.+            delta' <- addVarConCt delta x (PmAltConLike (RealDataCon dc)) [] [y]             pure (y, delta')       runMaybeT (foldlM build_newtype (x, delta) dcs) >>= \case         Nothing -> pure []@@ -1503,10 +1574,10 @@       case guessConLikeUnivTyArgsFromResTy env ty cl of         Nothing -> pure [delta] -- No idea idea how to refine this one, so just finish off with a wildcard         Just arg_tys -> do-          (arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl-          let new_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars)+          (tvs, arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl+          let new_tm_cs = unitBag (TmConCt x (PmAltConLike cl) tvs arg_vars)           -- Now check satifiability-          mb_delta <- pmIsSatisfiable delta new_tm_cs new_ty_cs strict_arg_tys+          mb_delta <- pmIsSatisfiable delta new_ty_cs new_tm_cs strict_arg_tys           tracePm "instantiate_cons" (vcat [ ppr x                                            , ppr (idType x)                                            , ppr ty@@ -1538,14 +1609,11 @@ -- | See if we already encountered a semantically equivalent expression and -- return its representative. representCoreExpr :: Delta -> CoreExpr -> DsM (Delta, Id)-representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e = do-  dflags <- getDynFlags-  let e' = simpleOptExpr dflags e-  case lookupCoreMap reps e' of-    Just rep -> pure (delta, rep)-    Nothing  -> do-      rep <- mkPmId (exprType e')-      let reps'  = extendCoreMap reps e' rep+representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e+  | Just rep <- lookupCoreMap reps e = pure (delta, rep)+  | otherwise = do+      rep <- mkPmId (exprType e)+      let reps'  = extendCoreMap reps e rep       let delta' = delta{ delta_tm_st = ts{ ts_reps = reps' } }       pure (delta', rep) @@ -1554,8 +1622,12 @@ -- type PmM a = StateT Delta (MaybeT DsM) a  -- | Records that a variable @x@ is equal to a 'CoreExpr' @e@.-addVarCoreCt :: Delta -> Id -> CoreExpr -> DsM (Maybe Delta)-addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta)+addVarCoreCt :: Delta -> Id -> CoreExpr -> MaybeT DsM Delta+addVarCoreCt delta x e = do+  dflags <- getDynFlags+  let e' = simpleOptExpr dflags e+  lift $ tracePm "addVarCoreCt" (ppr x $$ ppr e $$ ppr e')+  execStateT (core_expr x e') delta   where     -- | Takes apart a 'CoreExpr' and tries to extract as much information about     -- literals and constructor applications as possible.@@ -1574,14 +1646,21 @@       = case unpackFS s of           -- We need this special case to break a loop with coreExprAsPmLit           -- Otherwise we alternate endlessly between [] and ""-          [] -> data_con_app x nilDataCon []+          [] -> data_con_app x nilDataCon [] []           s' -> core_expr x (mkListExpr charTy (map mkCharExpr s'))       | Just lit <- coreExprAsPmLit e       = pm_lit x lit-      | Just (_in_scope, _empty_floats@[], dc, _arg_tys, args)+      | Just (in_scope, _empty_floats@[], dc, _arg_tys, args)             <- exprIsConApp_maybe in_scope_env e-      = do { arg_ids <- traverse bind_expr args-           ; data_con_app x dc arg_ids }+      = do { let dc_ex_tvs               = dataConExTyCoVars dc+                 arty                    = dataConSourceArity dc+                 (_ex_ty_args, val_args) = splitAtList dc_ex_tvs args+                 vis_args                = reverse $ take arty $ reverse val_args+           ; uniq_supply <- lift $ lift $ getUniqueSupplyM+           ; let (_, ex_tvs) = cloneTyVarBndrs (mkEmptyTCvSubst in_scope) dc_ex_tvs uniq_supply+           -- See Note [Why we don't record existential type constraints]+           ; arg_ids <- traverse bind_expr vis_args+           ; data_con_app x dc ex_tvs arg_ids }       -- See Note [Detecting pattern synonym applications in expressions]       | Var y <- e, Nothing <- isDataConId_maybe x       -- We don't consider DataCons flexible variables@@ -1612,22 +1691,38 @@         represent_expr e = StateT $ \delta ->           swap <$> lift (representCoreExpr delta e) -    data_con_app :: Id -> DataCon -> [Id] -> StateT Delta (MaybeT DsM) ()-    data_con_app x dc args = pm_alt_con_app x (PmAltConLike (RealDataCon dc)) args+    data_con_app :: Id -> DataCon -> [TyVar] -> [Id] -> StateT Delta (MaybeT DsM) ()+    data_con_app x dc tvs args = pm_alt_con_app x (PmAltConLike (RealDataCon dc)) tvs args      pm_lit :: Id -> PmLit -> StateT Delta (MaybeT DsM) ()-    pm_lit x lit = pm_alt_con_app x (PmAltLit lit) []+    pm_lit x lit = pm_alt_con_app x (PmAltLit lit) [] []      -- | Adds the given constructor application as a solution for @x@.-    pm_alt_con_app :: Id -> PmAltCon -> [Id] -> StateT Delta (MaybeT DsM) ()-    pm_alt_con_app x con args = modifyT $ \delta -> addVarConCt delta x con args+    pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Delta (MaybeT DsM) ()+    pm_alt_con_app x con tvs args = modifyT $ \delta -> addVarConCt delta x con tvs args  -- | Like 'modify', but with an effectful modifier action modifyT :: Monad m => (s -> m s) -> StateT s m () modifyT f = StateT $ fmap ((,) ()) . f -{- Note [Detecting pattern synonym applications in expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Why we don't record existential type constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have++  data Ex where Ex :: a -> Ex+  f _ | let x = Ex @Int 15 = case x of Ex -> ...++we see that `Ex`'s existential in the `Ex` application in the RHS of `x` is+bound to `Int`. Eventually this application will run by `addVarCoreCt`,+which freshens `a` to `a'` and adds the constraint `x ~ Ex @a' 15`.++Now, we *could* add the constraint @a' ~ Int@, but that is never useful, because+types are irrelevant. And in fact, if the programmer assumed that @a' ~ Int@+in the case alt, it would be rejected as a type error. So we simply don't+include the constraint.++Note [Detecting pattern synonym applications in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we fail to detect pattern synonyms in scrutinees and RHS of guards. This could be alleviated with considerable effort and complexity, but the returns are meager. Consider:@@ -1639,12 +1734,11 @@       P 15 ->  Compared to the situation where P and Q are DataCons, the lack of generativity-means we could never flag Q as redundant.-(also see Note [Undecidable Equality for PmAltCons] in PmTypes.)-On the other hand, if we fail to recognise the pattern synonym, we flag the-pattern match as inexhaustive. That wouldn't happen if we had knowledge about-the scrutinee, in which case the oracle basically knows "If it's a P, then its-field is 15".+means we could never flag Q as redundant. (also see Note [Undecidable Equality+for PmAltCons] in PmTypes.) On the other hand, if we fail to recognise the+pattern synonym, we flag the pattern match as inexhaustive. That wouldn't happen+if we had knowledge about the scrutinee, in which case the oracle basically+knows "If it's a P, then its field is 15".  This is a pretty narrow use case and I don't think we should to try to fix it until a user complains energetically.
compiler/GHC/HsToCore/PmCheck/Ppr.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- | Provides factilities for pretty-printing 'Delta's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.PmCheck.Ppr (@@ -143,7 +145,7 @@ pprPmVar prec x = do   delta <- ask   case lookupSolution delta x of-    Just (alt, args) -> pprPmAltCon prec alt args+    Just (alt, _tvs, args) -> pprPmAltCon prec alt args     Nothing          -> fromMaybe typed_wildcard <$> checkRefuts x       where         -- if we have no info about the parameter and would just print a@@ -203,7 +205,7 @@ pmExprAsList delta = go_con []   where     go_var rev_pref x-      | Just (alt, args) <- lookupSolution delta x+      | Just (alt, _tvs, args) <- lookupSolution delta x       = go_con rev_pref alt args     go_var rev_pref x       | Just pref <- nonEmpty (reverse rev_pref)
+ compiler/GHC/Iface/Binary.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}++--+--  (c) The University of Glasgow 2002-2006+--++{-# OPTIONS_GHC -O2 #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++-- | Binary interface file support.+module GHC.Iface.Binary (+        -- * Public API for interface file serialisation+        writeBinIface,+        readBinIface,+        getSymtabName,+        getDictFastString,+        CheckHiWay(..),+        TraceBinIFaceReading(..),+        getWithUserData,+        putWithUserData,++        -- * Internal serialisation functions+        getSymbolTable,+        putName,+        putDictionary,+        putFastString,+        putSymbolTable,+        BinSymbolTable(..),+        BinDictionary(..)++    ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnMonad+import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )+import GHC.Iface.Env+import HscTypes+import Module+import Name+import DynFlags+import UniqFM+import UniqSupply+import Panic+import Binary+import SrcLoc+import ErrUtils+import FastMutInt+import Unique+import Outputable+import NameCache+import GHC.Platform+import FastString+import Constants+import Util++import Data.Array+import Data.Array.ST+import Data.Array.Unsafe+import Data.Bits+import Data.Char+import Data.Word+import Data.IORef+import Data.Foldable+import Control.Monad+import Control.Monad.ST+import Control.Monad.Trans.Class+import qualified Control.Monad.Trans.State.Strict as State++-- ---------------------------------------------------------------------------+-- Reading and writing binary interface files+--++data CheckHiWay = CheckHiWay | IgnoreHiWay+    deriving Eq++data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading+    deriving Eq++-- | Read an interface file+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath+             -> TcRnIf a b ModIface+readBinIface checkHiWay traceBinIFaceReading hi_path = do+    ncu <- mkNameCacheUpdater+    dflags <- getDynFlags+    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu++readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath+              -> NameCacheUpdater+              -> IO ModIface+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do+    let printer :: SDoc -> IO ()+        printer = case traceBinIFaceReading of+                      TraceBinIFaceReading -> \sd ->+                          putLogMsg dflags+                                    NoReason+                                    SevOutput+                                    noSrcSpan+                                    (defaultDumpStyle dflags)+                                    sd+                      QuietBinIFaceReading -> \_ -> return ()++        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()+        wantedGot what wanted got ppr' =+            printer (text what <> text ": " <>+                     vcat [text "Wanted " <> ppr' wanted <> text ",",+                           text "got    " <> ppr' got])++        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()+        errorOnMismatch what wanted got =+            -- This will be caught by readIface which will emit an error+            -- msg containing the iface module name.+            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError+                         (what ++ " (wanted " ++ show wanted+                               ++ ", got "    ++ show got ++ ")")+    bh <- Binary.readBinMem hi_path++    -- Read the magic number to check that this really is a GHC .hi file+    -- (This magic number does not change when we change+    --  GHC interface file format)+    magic <- get bh+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr+    errorOnMismatch "magic number mismatch: old/corrupt interface file?"+        (binaryInterfaceMagic dflags) magic++    -- Note [dummy iface field]+    -- read a dummy 32/64 bit value.  This field used to hold the+    -- dictionary pointer in old interface file formats, but now+    -- the dictionary pointer is after the version (where it+    -- should be).  Also, the serialisation of value of type "Bin+    -- a" used to depend on the word size of the machine, now they+    -- are always 32 bits.+    if wORD_SIZE dflags == 4+        then do _ <- Binary.get bh :: IO Word32; return ()+        else do _ <- Binary.get bh :: IO Word64; return ()++    -- Check the interface file version and ways.+    check_ver  <- get bh+    let our_ver = show hiVersion+    wantedGot "Version" our_ver check_ver text+    errorOnMismatch "mismatched interface file versions" our_ver check_ver++    check_way <- get bh+    let way_descr = getWayDescr dflags+    wantedGot "Way" way_descr check_way ppr+    when (checkHiWay == CheckHiWay) $+        errorOnMismatch "mismatched interface file ways" way_descr check_way+    getWithUserData ncu bh+++-- | This performs a get action after reading the dictionary and symbol+-- table. It is necessary to run this before trying to deserialise any+-- Names or FastStrings.+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a+getWithUserData ncu bh = do+    -- Read the dictionary+    -- The next word in the file is a pointer to where the dictionary is+    -- (probably at the end of the file)+    dict_p <- Binary.get bh+    data_p <- tellBin bh          -- Remember where we are now+    seekBin bh dict_p+    dict   <- getDictionary bh+    seekBin bh data_p             -- Back to where we were before++    -- Initialise the user-data field of bh+    bh <- do+        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")+                                                     (getDictFastString dict)+        symtab_p <- Binary.get bh     -- Get the symtab ptr+        data_p <- tellBin bh          -- Remember where we are now+        seekBin bh symtab_p+        symtab <- getSymbolTable bh ncu+        seekBin bh data_p             -- Back to where we were before++        -- It is only now that we know how to get a Name+        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)+                                               (getDictFastString dict)++    -- Read the interface file+    get bh++-- | Write an interface file+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()+writeBinIface dflags hi_path mod_iface = do+    bh <- openBinMem initBinMemSize+    put_ bh (binaryInterfaceMagic dflags)++   -- dummy 32/64-bit field before the version/way for+   -- compatibility with older interface file formats.+   -- See Note [dummy iface field] above.+    if wORD_SIZE dflags == 4+        then Binary.put_ bh (0 :: Word32)+        else Binary.put_ bh (0 :: Word64)++    -- The version and way descriptor go next+    put_ bh (show hiVersion)+    let way_descr = getWayDescr dflags+    put_  bh way_descr+++    putWithUserData (debugTraceMsg dflags 3) bh mod_iface+    -- And send the result to the file+    writeBinMem bh hi_path++-- | Put a piece of data with an initialised `UserData` field. This+-- is necessary if you want to serialise Names or FastStrings.+-- It also writes a symbol table and the dictionary.+-- This segment should be read using `getWithUserData`.+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()+putWithUserData log_action bh payload = do+    -- Remember where the dictionary pointer will go+    dict_p_p <- tellBin bh+    -- Placeholder for ptr to dictionary+    put_ bh dict_p_p++    -- Remember where the symbol table pointer will go+    symtab_p_p <- tellBin bh+    put_ bh symtab_p_p+    -- Make some initial state+    symtab_next <- newFastMutInt+    writeFastMutInt symtab_next 0+    symtab_map <- newIORef emptyUFM+    let bin_symtab = BinSymbolTable {+                         bin_symtab_next = symtab_next,+                         bin_symtab_map  = symtab_map }+    dict_next_ref <- newFastMutInt+    writeFastMutInt dict_next_ref 0+    dict_map_ref <- newIORef emptyUFM+    let bin_dict = BinDictionary {+                       bin_dict_next = dict_next_ref,+                       bin_dict_map  = dict_map_ref }++    -- Put the main thing,+    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)+                                                  (putName bin_dict bin_symtab)+                                                  (putFastString bin_dict)+    put_ bh payload++    -- Write the symtab pointer at the front of the file+    symtab_p <- tellBin bh        -- This is where the symtab will start+    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder+    seekBin bh symtab_p           -- Seek back to the end of the file++    -- Write the symbol table itself+    symtab_next <- readFastMutInt symtab_next+    symtab_map  <- readIORef symtab_map+    putSymbolTable bh symtab_next symtab_map+    log_action (text "writeBinIface:" <+> int symtab_next+                                <+> text "Names")++    -- NB. write the dictionary after the symbol table, because+    -- writing the symbol table may create more dictionary entries.++    -- Write the dictionary pointer at the front of the file+    dict_p <- tellBin bh          -- This is where the dictionary will start+    putAt bh dict_p_p dict_p      -- Fill in the placeholder+    seekBin bh dict_p             -- Seek back to the end of the file++    -- Write the dictionary itself+    dict_next <- readFastMutInt dict_next_ref+    dict_map  <- readIORef dict_map_ref+    putDictionary bh dict_next dict_map+    log_action (text "writeBinIface:" <+> int dict_next+                                <+> text "dict entries")++++-- | Initial ram buffer to allocate for writing interface files+initBinMemSize :: Int+initBinMemSize = 1024 * 1024++binaryInterfaceMagic :: DynFlags -> Word32+binaryInterfaceMagic dflags+ | target32Bit (targetPlatform dflags) = 0x1face+ | otherwise                           = 0x1face64+++-- -----------------------------------------------------------------------------+-- The symbol table+--++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()+putSymbolTable bh next_off symtab = do+    put_ bh next_off+    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))+      -- It's OK to use nonDetEltsUFM here because the elements have+      -- indices that array uses to create order+    mapM_ (\n -> serialiseName bh n symtab) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+    sz <- get bh+    od_names <- sequence (replicate sz (get bh))+    updateNameCache ncu $ \namecache ->+        runST $ flip State.evalStateT namecache $ do+            mut_arr <- lift $ newSTArray_ (0, sz-1)+            for_ (zip [0..] od_names) $ \(i, odn) -> do+                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn+                lift $ writeArray mut_arr i n+                State.put nc+            arr <- lift $ unsafeFreeze mut_arr+            namecache' <- State.get+            return (namecache', arr)+  where+    -- This binding is required because the type of newArray_ cannot be inferred+    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)+    newSTArray_ = newArray_++type OnDiskName = (UnitId, ModuleName, OccName)++fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)+fromOnDiskName nc (pid, mod_name, occ) =+    let mod   = mkModule pid mod_name+        cache = nsNames nc+    in case lookupOrigNameCache cache  mod occ of+           Just name -> (nc, name)+           Nothing   ->+               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+                   name       = mkExternalName uniq mod occ noSrcSpan+                   new_cache  = extendNameCache cache mod occ name+               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )++serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()+serialiseName bh name _ = do+    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)+++-- Note [Symbol table representation of names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- An occurrence of a name in an interface file is serialized as a single 32-bit+-- word. The format of this word is:+--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx+--   A normal name. x is an index into the symbol table+--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy+--   A known-key name. x is the Unique's Char, y is the int part. We assume that+--   all known-key uniques fit in this space. This is asserted by+--   PrelInfo.knownKeyNamesOkay.+--+-- During serialization we check for known-key things using isKnownKeyName.+-- During deserialization we use lookupKnownKeyName to get from the unique back+-- to its corresponding Name.+++-- See Note [Symbol table representation of names]+putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()+putName _dict BinSymbolTable{+               bin_symtab_map = symtab_map_ref,+               bin_symtab_next = symtab_next }+        bh name+  | isKnownKeyName name+  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits+  = -- ASSERT(u < 2^(22 :: Int))+    put_ bh (0x80000000+             .|. (fromIntegral (ord c) `shiftL` 22)+             .|. (fromIntegral u :: Word32))++  | otherwise+  = do symtab_map <- readIORef symtab_map_ref+       case lookupUFM symtab_map name of+         Just (off,_) -> put_ bh (fromIntegral off :: Word32)+         Nothing -> do+            off <- readFastMutInt symtab_next+            -- MASSERT(off < 2^(30 :: Int))+            writeFastMutInt symtab_next (off+1)+            writeIORef symtab_map_ref+                $! addToUFM symtab_map name (off,name)+            put_ bh (fromIntegral off :: Word32)++-- See Note [Symbol table representation of names]+getSymtabName :: NameCacheUpdater+              -> Dictionary -> SymbolTable+              -> BinHandle -> IO Name+getSymtabName _ncu _dict symtab bh = do+    i :: Word32 <- get bh+    case i .&. 0xC0000000 of+      0x00000000 -> return $! symtab ! fromIntegral i++      0x80000000 ->+        let+          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))+          ix  = fromIntegral i .&. 0x003FFFFF+          u   = mkUnique tag ix+        in+          return $! case lookupKnownKeyName u of+                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"+                                          (ppr i $$ ppr (unpkUnique u))+                      Just n  -> n++      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)++data BinSymbolTable = BinSymbolTable {+        bin_symtab_next :: !FastMutInt, -- The next index to use+        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))+                                -- indexed by Name+  }++putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()+putFastString dict bh fs = allocateFastString dict fs >>= put_ bh++allocateFastString :: BinDictionary -> FastString -> IO Word32+allocateFastString BinDictionary { bin_dict_next = j_r,+                                   bin_dict_map  = out_r} f = do+    out <- readIORef out_r+    let uniq = getUnique f+    case lookupUFM out uniq of+        Just (j, _)  -> return (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out uniq (j, f)+           return (fromIntegral j :: Word32)++getDictFastString :: Dictionary -> BinHandle -> IO FastString+getDictFastString dict bh = do+    j <- get bh+    return $! (dict ! fromIntegral (j :: Word32))++data BinDictionary = BinDictionary {+        bin_dict_next :: !FastMutInt, -- The next index to use+        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))+                                -- indexed by FastString+  }++getWayDescr :: DynFlags -> String+getWayDescr dflags+  | platformUnregisterised (targetPlatform dflags) = 'u':tag+  | otherwise                                      =     tag+  where tag = buildTag dflags+        -- if this is an unregisterised build, make sure our interfaces+        -- can't be used by a registerised build.
+ compiler/GHC/Iface/Env.hs view
@@ -0,0 +1,298 @@+-- (c) The University of Glasgow 2002-2006++{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}++module GHC.Iface.Env (+        newGlobalBinder, newInteractiveBinder,+        externaliseName,+        lookupIfaceTop,+        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,+        newIfaceName, newIfaceNames,+        extendIfaceIdEnv, extendIfaceTyVarEnv,+        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,+        lookupIfaceTyVar, extendIfaceEnvs,+        setNameModule,++        ifaceExportNames,++        -- Name-cache stuff+        allocateGlobalBinder, updNameCacheTc,+        mkNameCacheUpdater, NameCacheUpdater(..),+   ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnMonad+import HscTypes+import Type+import Var+import Name+import Avail+import Module+import FastString+import FastStringEnv+import GHC.Iface.Type+import NameCache+import UniqSupply+import SrcLoc++import Outputable+import Data.List     ( partition )++{-+*********************************************************+*                                                      *+        Allocating new Names in the Name Cache+*                                                      *+*********************************************************++See Also: Note [The Name Cache] in NameCache+-}++newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name+-- Used for source code and interface files, to make the+-- Name for a thing, given its Module and OccName+-- See Note [The Name Cache]+--+-- The cache may already already have a binding for this thing,+-- because we may have seen an occurrence before, but now is the+-- moment when we know its Module and SrcLoc in their full glory++newGlobalBinder mod occ loc+  = do { name <- updNameCacheTc mod occ $ \name_cache ->+                 allocateGlobalBinder name_cache mod occ loc+       ; traceIf (text "newGlobalBinder" <+>+                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))+       ; return name }++newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name+-- Works in the IO monad, and gets the Module+-- from the interactive context+newInteractiveBinder hsc_env occ loc+ = do { let mod = icInteractiveModule (hsc_IC hsc_env)+       ; updNameCacheIO hsc_env mod occ $ \name_cache ->+         allocateGlobalBinder name_cache mod occ loc }++allocateGlobalBinder+  :: NameCache+  -> Module -> OccName -> SrcSpan+  -> (NameCache, Name)+-- See Note [The Name Cache]+allocateGlobalBinder name_supply mod occ loc+  = case lookupOrigNameCache (nsNames name_supply) mod occ of+        -- A hit in the cache!  We are at the binding site of the name.+        -- This is the moment when we know the SrcLoc+        -- of the Name, so we set this field in the Name we return.+        --+        -- Then (bogus) multiple bindings of the same Name+        -- get different SrcLocs can be reported as such.+        --+        -- Possible other reason: it might be in the cache because we+        --      encountered an occurrence before the binding site for an+        --      implicitly-imported Name.  Perhaps the current SrcLoc is+        --      better... but not really: it'll still just say 'imported'+        --+        -- IMPORTANT: Don't mess with wired-in names.+        --            Their wired-in-ness is in their NameSort+        --            and their Module is correct.++        Just name | isWiredInName name+                  -> (name_supply, name)+                  | otherwise+                  -> (new_name_supply, name')+                  where+                    uniq            = nameUnique name+                    name'           = mkExternalName uniq mod occ loc+                                      -- name' is like name, but with the right SrcSpan+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'+                    new_name_supply = name_supply {nsNames = new_cache}++        -- Miss in the cache!+        -- Build a completely new Name, and put it in the cache+        _ -> (new_name_supply, name)+                  where+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)+                    name            = mkExternalName uniq mod occ loc+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}++ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]+ifaceExportNames exports = return exports++-- | A function that atomically updates the name cache given a modifier+-- function.  The second result of the modifier function will be the result+-- of the IO action.+newtype NameCacheUpdater+      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }++mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater+mkNameCacheUpdater = do { hsc_env <- getTopEnv+                        ; let !ncRef = hsc_NC hsc_env+                        ; return (NCU (updNameCache ncRef)) }++updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))+               -> TcRnIf a b c+updNameCacheTc mod occ upd_fn = do {+    hsc_env <- getTopEnv+  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }+++updNameCacheIO ::  HscEnv -> Module -> OccName+               -> (NameCache -> (NameCache, c))+               -> IO c+updNameCacheIO hsc_env mod occ upd_fn = do {++    -- First ensure that mod and occ are evaluated+    -- If not, chaos can ensue:+    --      we read the name-cache+    --      then pull on mod (say)+    --      which does some stuff that modifies the name cache+    -- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..)++    mod `seq` occ `seq` return ()+  ; updNameCache (hsc_NC hsc_env) upd_fn }+++{-+************************************************************************+*                                                                      *+                Name cache access+*                                                                      *+************************************************************************+-}++-- | Look up the 'Name' for a given 'Module' and 'OccName'.+-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad+-- and 'Module' is simply that of the 'ModIface' you are typechecking.+lookupOrig :: Module -> OccName -> TcRnIf a b Name+lookupOrig mod occ+  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)++        ; updNameCacheTc mod occ $ lookupNameCache mod occ }++lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name+lookupOrigIO hsc_env mod occ+  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ++lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)+-- Lookup up the (Module,OccName) in the NameCache+-- If you find it, return it; if not, allocate a fresh original name and extend+-- the NameCache.+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.+-- If we need to explore its value we will load Foo.hi; but meanwhile all we+-- need is a Name for it.+lookupNameCache mod occ name_cache =+  case lookupOrigNameCache (nsNames name_cache) mod occ of {+    Just name -> (name_cache, name);+    Nothing   ->+        case takeUniqFromSupply (nsUniqs name_cache) of {+          (uniq, us) ->+              let+                name      = mkExternalName uniq mod occ noSrcSpan+                new_cache = extendNameCache (nsNames name_cache) mod occ name+              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}++externaliseName :: Module -> Name -> TcRnIf m n Name+-- Take an Internal Name and make it an External one,+-- with the same unique+externaliseName mod name+  = do { let occ = nameOccName name+             loc = nameSrcSpan name+             uniq = nameUnique name+       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder+       ; updNameCacheTc mod occ $ \ ns ->+         let name' = mkExternalName uniq mod occ loc+             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }+         in (ns', name') }++-- | Set the 'Module' of a 'Name'.+setNameModule :: Maybe Module -> Name -> TcRnIf m n Name+setNameModule Nothing n = return n+setNameModule (Just m) n =+    newGlobalBinder m (nameOccName n) (nameSrcSpan n)++{-+************************************************************************+*                                                                      *+                Type variables and local Ids+*                                                                      *+************************************************************************+-}++tcIfaceLclId :: FastString -> IfL Id+tcIfaceLclId occ+  = do  { lcl <- getLclEnv+        ; case (lookupFsEnv (if_id_env lcl) occ) of+            Just ty_var -> return ty_var+            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)+        }++extendIfaceIdEnv :: [Id] -> IfL a -> IfL a+extendIfaceIdEnv ids thing_inside+  = do  { env <- getLclEnv+        ; let { id_env' = extendFsEnvList (if_id_env env) pairs+              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }+        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }+++tcIfaceTyVar :: FastString -> IfL TyVar+tcIfaceTyVar occ+  = do  { lcl <- getLclEnv+        ; case (lookupFsEnv (if_tv_env lcl) occ) of+            Just ty_var -> return ty_var+            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)+        }++lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)+lookupIfaceTyVar (occ, _)+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_tv_env lcl) occ) }++lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)+lookupIfaceVar (IfaceIdBndr (occ, _))+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_id_env lcl) occ) }+lookupIfaceVar (IfaceTvBndr (occ, _))+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_tv_env lcl) occ) }++extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a+extendIfaceTyVarEnv tyvars thing_inside+  = do  { env <- getLclEnv+        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs+              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }+        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }++extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a+extendIfaceEnvs tcvs thing_inside+  = extendIfaceTyVarEnv tvs $+    extendIfaceIdEnv    cvs $+    thing_inside+  where+    (tvs, cvs) = partition isTyVar tcvs++{-+************************************************************************+*                                                                      *+                Getting from RdrNames to Names+*                                                                      *+************************************************************************+-}++-- | Look up a top-level name from the current Iface module+lookupIfaceTop :: OccName -> IfL Name+lookupIfaceTop occ+  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }++newIfaceName :: OccName -> IfL Name+newIfaceName occ+  = do  { uniq <- newUnique+        ; return $! mkInternalName uniq occ noSrcSpan }++newIfaceNames :: [OccName] -> IfL [Name]+newIfaceNames occs+  = do  { uniqs <- newUniqueSupply+        ; return [ mkInternalName uniq occ noSrcSpan+                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
+ compiler/GHC/Iface/Env.hs-boot view
@@ -0,0 +1,9 @@+module GHC.Iface.Env where++import Module+import OccName+import TcRnMonad+import Name+import SrcLoc++newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
+ compiler/GHC/Iface/Ext/Ast.hs view
@@ -0,0 +1,1920 @@+{-+Main functions for .hie file generation+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Iface.Ext.Ast ( mkHieFile ) where++import GhcPrelude++import Avail                      ( Avails )+import Bag                        ( Bag, bagToList )+import BasicTypes+import BooleanFormula+import Class                      ( FunDep )+import CoreUtils                  ( exprType )+import ConLike                    ( conLikeName )+import Desugar                    ( deSugarExpr )+import FieldLabel+import GHC.Hs+import HscTypes+import Module                     ( ModuleName, ml_hs_file )+import MonadUtils                 ( concatMapM, liftIO )+import Name                       ( Name, nameSrcSpan, setNameLoc )+import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )+import SrcLoc+import TcHsSyn                    ( hsLitType, hsPatType )+import Type                       ( mkVisFunTys, Type )+import TysWiredIn                 ( mkListTy, mkSumTy )+import Var                        ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import GHC.Iface.Utils            ( mkIfaceExports )+import Panic++import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils++import qualified Data.Array as A+import qualified Data.ByteString as BS+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Data                  ( Data, Typeable )+import Data.List                  ( foldl1' )+import Data.Maybe                 ( listToMaybe )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class  ( lift )++{- Note [Updating HieAst for changes in the GHC AST]++When updating the code in this file for changes in the GHC AST, you+need to pay attention to the following things:++1) Symbols (Names/Vars/Modules) in the following categories:++   a) Symbols that appear in the source file that directly correspond to+   something the user typed+   b) Symbols that don't appear in the source, but should be in some sense+   "visible" to a user, particularly via IDE tooling or the like. This+   includes things like the names introduced by RecordWildcards (We record+   all the names introduced by a (..) in HIE files), and will include implicit+   parameters and evidence variables after one of my pending MRs lands.++2) Subtrees that may contain such symbols, or correspond to a SrcSpan in+   the file. This includes all `Located` things++For 1), you need to call `toHie` for one of the following instances++instance ToHie (Context (Located Name)) where ...+instance ToHie (Context (Located Var)) where ...+instance ToHie (IEContext (Located ModuleName)) where ...++`Context` is a data type that looks like:++data Context a = C ContextInfo a -- Used for names and bindings++`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like++data ContextInfo+  = Use                -- ^ regular variable+  | MatchBind+  | IEThing IEType     -- ^ import/export+  | TyDecl+  -- | Value binding+  | ValBind+      BindType     -- ^ whether or not the binding is in an instance+      Scope        -- ^ scope over which the value is bound+      (Maybe Span) -- ^ span of entire binding+  ...++It is used to annotate symbols in the .hie files with some extra information on+the context in which they occur and should be fairly self explanatory. You need+to select one that looks appropriate for the symbol usage. In very rare cases,+you might need to extend this sum type if none of the cases seem appropriate.++So, given a `Located Name` that is just being "used", and not defined at a+particular location, you would do the following:++   toHie $ C Use located_name++If you select one that corresponds to a binding site, you will need to+provide a `Scope` and a `Span` for your binding. Both of these are basically+`SrcSpans`.++The `SrcSpan` in the `Scope` is supposed to span over the part of the source+where the symbol can be legally allowed to occur. For more details on how to+calculate this, see Note [Capturing Scopes and other non local information]+in GHC.Iface.Ext.Ast.++The binding `Span` is supposed to be the span of the entire binding for+the name.++For a function definition `foo`:++foo x = x + y+  where y = x^2++The binding `Span` is the span of the entire function definition from `foo x`+to `x^2`.  For a class definition, this is the span of the entire class, and+so on.  If this isn't well defined for your bit of syntax (like a variable+bound by a lambda), then you can just supply a `Nothing`++There is a test that checks that all symbols in the resulting HIE file+occur inside their stated `Scope`. This can be turned on by passing the+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the+.hie file.++You may also want to provide a test in testsuite/test/hiefile that includes+a file containing your new construction, and tests that the calculated scope+is valid (by using -fvalidate-ide-info)++For subtrees in the AST that may contain symbols, the procedure is fairly+straightforward.  If you are extending the GHC AST, you will need to provide a+`ToHie` instance for any new types you may have introduced in the AST.++Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):++  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of+      HsVar _ (L _ var) ->+        [ toHie $ C Use (L mspan var)+             -- Patch up var location since typechecker removes it+        ]+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      ...+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]++If your subtree is `Located` or has a `SrcSpan` available, the output list+should contain a HieAst `Node` corresponding to the subtree. You can use+either `makeNode` or `getTypeNode` for this purpose, depending on whether it+makes sense to assign a `Type` to the subtree. After this, you just need+to concatenate the result of calling `toHie` on all subexpressions and+appropriately annotated symbols contained in the subtree.++The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed+to work for both the renamed and typechecked source. `getTypeNode` is from+the `HasType` class defined in this file, and it has different instances+for `GhcTc` and `GhcRn` that allow it to access the type of the expression+when given a typechecked AST:++class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = ... -- Actually get the type for this expression+instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type++If your subtree doesn't have a span available, you can omit the `makeNode`+call and just recurse directly in to the subexpressions.++-}++-- These synonyms match those defined in main/GHC.hs+type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]+                         , Maybe [(LIE GhcRn, Avails)]+                         , Maybe LHsDocString )+type TypecheckedSource = LHsBinds GhcTc+++{- Note [Name Remapping]+The Typechecker introduces new names for mono names in AbsBinds.+We don't care about the distinction between mono and poly bindings,+so we replace all occurrences of the mono name with the poly name.+-}+newtype HieState = HieState+  { name_remapping :: NameEnv Id+  }++initState :: HieState+initState = HieState emptyNameEnv++class ModifyState a where -- See Note [Name Remapping]+  addSubstitution :: a -> a -> HieState -> HieState++instance ModifyState Name where+  addSubstitution _ _ hs = hs++instance ModifyState Id where+  addSubstitution mono poly hs =+    hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}++modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState+modifyState = foldr go id+  where+    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f+    go _ f = f++type HieM = ReaderT HieState Hsc++-- | Construct an 'HieFile' from the outputs of the typechecker.+mkHieFile :: ModSummary+          -> TcGblEnv+          -> RenamedSource -> Hsc HieFile+mkHieFile ms ts rs = do+  let tc_binds = tcg_binds ts+  (asts', arr) <- getCompressedAsts tc_binds rs+  let Just src_file = ml_hs_file $ ms_location ms+  src <- liftIO $ BS.readFile src_file+  return $ HieFile+      { hie_hs_file = src_file+      , hie_module = ms_mod ms+      , hie_types = arr+      , hie_asts = asts'+      -- mkIfaceExports sorts the AvailInfos for stability+      , hie_exports = mkIfaceExports (tcg_exports ts)+      , hie_hs_src = src+      }++getCompressedAsts :: TypecheckedSource -> RenamedSource+  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs = do+  asts <- enrichHie ts rs+  return $ compressTypes asts++enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do+    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts+    rasts <- processGrp hsGrp+    imps <- toHie $ filter (not . ideclImplicit . unLoc) imports+    exps <- toHie $ fmap (map $ IEC Export . fst) exports+    let spanFile children = case children of+          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)+          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)+                             (realSrcSpanEnd   $ nodeSpan $ last children)++        modulify xs =+          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs++        asts = HieASTs+          $ resolveTyVarScopes+          $ M.map (modulify . mergeSortAsts)+          $ M.fromListWith (++)+          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts++        flat_asts = concat+          [ tasts+          , rasts+          , imps+          , exps+          ]+    return asts+  where+    processGrp grp = concatM+      [ toHie $ fmap (RS ModuleScope ) hs_valds grp+      , toHie $ hs_splcds grp+      , toHie $ hs_tyclds grp+      , toHie $ hs_derivds grp+      , toHie $ hs_fixds grp+      , toHie $ hs_defds grp+      , toHie $ hs_fords grp+      , toHie $ hs_warnds grp+      , toHie $ hs_annds grp+      , toHie $ hs_ruleds grp+      ]++getRealSpan :: SrcSpan -> Maybe Span+getRealSpan (RealSrcSpan sp) = Just sp+getRealSpan _ = Nothing++grhss_span :: GRHSs p body -> SrcSpan+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)+grhss_span (XGRHSs _) = panic "XGRHS has no span"++bindingsOnly :: [Context Name] -> [HieAST a]+bindingsOnly [] = []+bindingsOnly (C c n : xs) = case nameSrcSpan n of+  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)+          info = mempty{identInfo = S.singleton c}+  _ -> bindingsOnly xs++concatM :: Monad m => [m [a]] -> m [a]+concatM xs = concat <$> sequence xs++{- Note [Capturing Scopes and other non local information]+toHie is a local transformation, but scopes of bindings cannot be known locally,+hence we have to push the relevant info down into the binding nodes.+We use the following types (*Context and *Scoped) to wrap things and+carry the required info+(Maybe Span) always carries the span of the entire binding, including rhs+-}+data Context a = C ContextInfo a -- Used for names and bindings++data RContext a = RC RecFieldContext a+data RFContext a = RFC RecFieldContext (Maybe Span) a+-- ^ context for record fields++data IEContext a = IEC IEType a+-- ^ context for imports/exports++data BindContext a = BC BindType Scope a+-- ^ context for imports/exports++data PatSynFieldContext a = PSC (Maybe Span) a+-- ^ context for pattern synonym fields.++data SigContext a = SC SigInfo a+-- ^ context for type signatures++data SigInfo = SI SigType (Maybe Span)++data SigType = BindSig | ClassSig | InstSig++data RScoped a = RS Scope a+-- ^ Scope spans over everything to the right of a, (mostly) not+-- including a itself+-- (Includes a in a few special cases like recursive do bindings) or+-- let/where bindings++-- | Pattern scope+data PScoped a = PS (Maybe Span)+                    Scope       -- ^ use site of the pattern+                    Scope       -- ^ pattern to the right of a, not including a+                    a+  deriving (Typeable, Data) -- Pattern Scope++{- Note [TyVar Scopes]+Due to -XScopedTypeVariables, type variables can be in scope quite far from+their original binding. We resolve the scope of these type variables+in a separate pass+-}+data TScoped a = TS TyVarScope a -- TyVarScope++data TVScoped a = TVS TyVarScope Scope a -- TyVarScope+-- ^ First scope remains constant+-- Second scope is used to build up the scope of a tyvar over+-- things to its right, ala RScoped++-- | Each element scopes over the elements to the right+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]+listScopes _ [] = []+listScopes rhsScope [pat] = [RS rhsScope pat]+listScopes rhsScope (pat : pats) = RS sc pat : pats'+  where+    pats'@((RS scope p):_) = listScopes rhsScope pats+    sc = combineScopes scope $ mkScope $ getLoc p++-- | 'listScopes' specialised to 'PScoped' things+patScopes+  :: Maybe Span+  -> Scope+  -> Scope+  -> [LPat (GhcPass p)]+  -> [PScoped (LPat (GhcPass p))]+patScopes rsp useScope patScope xs =+  map (\(RS sc a) -> PS rsp useScope sc a) $+    listScopes patScope xs++-- | 'listScopes' specialised to 'TVScoped' things+tvScopes+  :: TyVarScope+  -> Scope+  -> [LHsTyVarBndr a]+  -> [TVScoped (LHsTyVarBndr a)]+tvScopes tvScope rhsScope xs =+  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs++{- Note [Scoping Rules for SigPat]+Explicitly quantified variables in pattern type signatures are not+brought into scope in the rhs, but implicitly quantified variables+are (HsWC and HsIB).+This is unlike other signatures, where explicitly quantified variables+are brought into the RHS Scope+For example+foo :: forall a. ...;+foo = ... -- a is in scope here++bar (x :: forall a. a -> a) = ... -- a is not in scope here+--   ^ a is in scope here (pattern body)++bax (x :: a) = ... -- a is in scope here+Because of HsWC and HsIB pass on their scope to their children+we must wrap the LHsType in pattern signatures in a+Shielded explicitly, so that the HsWC/HsIB scope is not passed+on the the LHsType+-}++data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead++type family ProtectedSig a where+  ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs+                                                GhcRn+                                                (Shielded (LHsType GhcRn)))+  ProtectedSig GhcTc = NoExtField++class ProtectSig a where+  protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a++instance (HasLoc a) => HasLoc (Shielded a) where+  loc (SH _ a) = loc a++instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where+  toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)++instance ProtectSig GhcTc where+  protectSig _ _ = noExtField++instance ProtectSig GhcRn where+  protectSig sc (HsWC a (HsIB b sig)) =+    HsWC a (HsIB b (SH sc sig))+  protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+  protectSig _ (XHsWildCardBndrs nec) = noExtCon nec++class HasLoc a where+  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can+  -- know what their implicit bindings are scoping over+  loc :: a -> SrcSpan++instance HasLoc thing => HasLoc (TScoped thing) where+  loc (TS _ a) = loc a++instance HasLoc thing => HasLoc (PScoped thing) where+  loc (PS _ _ _ a) = loc a++instance HasLoc (LHsQTyVars GhcRn) where+  loc (HsQTvs _ vs) = loc vs+  loc _ = noSrcSpan++instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where+  loc (HsIB _ a) = loc a+  loc _ = noSrcSpan++instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where+  loc (HsWC _ a) = loc a+  loc _ = noSrcSpan++instance HasLoc (Located a) where+  loc (L l _) = l++instance HasLoc a => HasLoc [a] where+  loc [] = noSrcSpan+  loc xs = foldl1' combineSrcSpans $ map loc xs++instance HasLoc a => HasLoc (FamEqn s a) where+  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]+  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans+                                              [loc a, loc tvs, loc b, loc c]+  loc _ = noSrcSpan+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where+  loc (HsValArg tm) = loc tm+  loc (HsTypeArg _ ty) = loc ty+  loc (HsArgPar sp)  = sp++instance HasLoc (HsDataDefn GhcRn) where+  loc def@(HsDataDefn{}) = loc $ dd_cons def+    -- Only used for data family instances, so we only need rhs+    -- Most probably the rest will be unhelpful anyway+  loc _ = noSrcSpan++{- Note [Real DataCon Name]+The typechecker substitutes the conLikeWrapId for the name, but we don't want+this showing up in the hieFile, so we replace the name in the Id with the+original datacon name+See also Note [Data Constructor Naming]+-}+class HasRealDataConName p where+  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)++instance HasRealDataConName GhcRn where+  getRealDataCon _ n = n+instance HasRealDataConName GhcTc where+  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =+    L sp (setVarName var (conLikeName con))++-- | The main worker class+-- See Note [Updating HieAst for changes in the GHC AST] for more information+-- on how to add/modify instances for this.+class ToHie a where+  toHie :: a -> HieM [HieAST Type]++-- | Used to collect type info+class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]++instance (ToHie a) => ToHie [a] where+  toHie = concatMapM toHie++instance (ToHie a) => ToHie (Bag a) where+  toHie = toHie . bagToList++instance (ToHie a) => ToHie (Maybe a) where+  toHie = maybe (pure []) toHie++instance ToHie (Context (Located NoExtField)) where+  toHie _ = pure []++instance ToHie (TScoped NoExtField) where+  toHie _ = pure []++instance ToHie (IEContext (Located ModuleName)) where+  toHie (IEC c (L (RealSrcSpan span) mname)) =+      pure $ [Node (NodeInfo S.empty [] idents) span []]+    where details = mempty{identInfo = S.singleton (IEThing c)}+          idents = M.singleton (Left mname) details+  toHie _ = pure []++instance ToHie (Context (Located Var)) where+  toHie c = case c of+      C context (L (RealSrcSpan span) name')+        -> do+        m <- asks name_remapping+        let name = case lookupNameEnv m (varName name') of+              Just var -> var+              Nothing-> name'+        pure+          [Node+            (NodeInfo S.empty [] $+              M.singleton (Right $ varName name)+                          (IdentifierDetails (Just $ varType name')+                                             (S.singleton context)))+            span+            []]+      _ -> pure []++instance ToHie (Context (Located Name)) where+  toHie c = case c of+      C context (L (RealSrcSpan span) name') -> do+        m <- asks name_remapping+        let name = case lookupNameEnv m name' of+              Just var -> varName var+              Nothing -> name'+        pure+          [Node+            (NodeInfo S.empty [] $+              M.singleton (Right name)+                          (IdentifierDetails Nothing+                                             (S.singleton context)))+            span+            []]+      _ -> pure []++-- | Dummy instances - never called+instance ToHie (TScoped (LHsSigWcType GhcTc)) where+  toHie _ = pure []+instance ToHie (TScoped (LHsWcType GhcTc)) where+  toHie _ = pure []+instance ToHie (SigContext (LSig GhcTc)) where+  toHie _ = pure []+instance ToHie (TScoped Type) where+  toHie _ = pure []++instance HasType (LHsBind GhcRn) where+  getTypeNode (L spn bind) = makeNode bind spn++instance HasType (LHsBind GhcTc) where+  getTypeNode (L spn bind) = case bind of+      FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)+      _ -> makeNode bind spn++instance HasType (Located (Pat GhcRn)) where+  getTypeNode (L spn pat) = makeNode pat spn++instance HasType (Located (Pat GhcTc)) where+  getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat)++instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn++-- | This instance tries to construct 'HieAST' nodes which include the type of+-- the expression. It is not yet possible to do this efficiently for all+-- expression forms, so we skip filling in the type for those inputs.+--+-- 'HsApp', for example, doesn't have any type information available directly on+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then+-- query the type of that. Yet both the desugaring call and the type query both+-- involve recursive calls to the function and argument! This is particularly+-- problematic when you realize that the HIE traversal will eventually visit+-- those nodes too and ask for their types again.+--+-- Since the above is quite costly, we just skip cases where computing the+-- expression's type is going to be expensive.+--+-- See #16233+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = lift $+    -- Some expression forms have their type immediately available+    let tyOpt = case e' of+          HsLit _ l -> Just (hsLitType l)+          HsOverLit _ o -> Just (overLitType o)++          HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)+          HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)+          HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)++          ExplicitList  ty _ _   -> Just (mkListTy ty)+          ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)+          HsDo          ty _ _   -> Just ty+          HsMultiIf     ty _     -> Just ty++          _ -> Nothing++    in+    case tyOpt of+      Just t -> makeTypeNode e' spn t+      Nothing+        | skipDesugaring e' -> fallback+        | otherwise -> do+            hs_env <- Hsc $ \e w -> return (e,w)+            (_,mbe) <- liftIO $ deSugarExpr hs_env e+            maybe fallback (makeTypeNode e' spn . exprType) mbe+    where+      fallback = makeNode e' spn++      matchGroupType :: MatchGroupTc -> Type+      matchGroupType (MatchGroupTc args res) = mkVisFunTys args res++      -- | Skip desugaring of these expressions for performance reasons.+      --+      -- See impact on Haddock output (esp. missing type annotations or links)+      -- before marking more things here as 'False'. See impact on Haddock+      -- performance before marking more things as 'True'.+      skipDesugaring :: HsExpr a -> Bool+      skipDesugaring e = case e of+        HsVar{}        -> False+        HsUnboundVar{} -> False+        HsConLikeOut{} -> False+        HsRecFld{}     -> False+        HsOverLabel{}  -> False+        HsIPVar{}      -> False+        HsWrap{}       -> False+        _              -> True++instance ( ToHie (Context (Located (IdP a)))+         , ToHie (MatchGroup a (LHsExpr a))+         , ToHie (PScoped (LPat a))+         , ToHie (GRHSs a (LHsExpr a))+         , ToHie (LHsExpr a)+         , ToHie (Located (PatSynBind a a))+         , HasType (LHsBind a)+         , ModifyState (IdP a)+         , Data (HsBind a)+         ) => ToHie (BindContext (LHsBind a)) where+  toHie (BC context scope b@(L span bind)) =+    concatM $ getTypeNode b : case bind of+      FunBind{fun_id = name, fun_matches = matches} ->+        [ toHie $ C (ValBind context scope $ getRealSpan span) name+        , toHie matches+        ]+      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->+        [ toHie $ PS (getRealSpan span) scope NoScope lhs+        , toHie rhs+        ]+      VarBind{var_rhs = expr} ->+        [ toHie expr+        ]+      AbsBinds{abs_exports = xs, abs_binds = binds} ->+        [ local (modifyState xs) $ -- Note [Name Remapping]+            toHie $ fmap (BC context scope) binds+        ]+      PatSynBind _ psb ->+        [ toHie $ L span psb -- PatSynBinds only occur at the top level+        ]+      XHsBindsLR _ -> []++instance ( ToHie (LMatch a body)+         ) => ToHie (MatchGroup a body) where+  toHie mg = concatM $ case mg of+    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->+      [ pure $ locOnly span+      , toHie alts+      ]+    MG{} -> []+    XMatchGroup _ -> []++instance ( ToHie (Context (Located (IdP a)))+         , ToHie (PScoped (LPat a))+         , ToHie (HsPatSynDir a)+         ) => ToHie (Located (PatSynBind a a)) where+    toHie (L sp psb) = concatM $ case psb of+      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->+        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var+        , toHie $ toBind dets+        , toHie $ PS Nothing lhsScope NoScope pat+        , toHie dir+        ]+        where+          lhsScope = combineScopes varScope detScope+          varScope = mkLScope var+          detScope = case dets of+            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args+            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)+            (RecCon r) -> foldr go NoScope r+          go (RecordPatSynField a b) c = combineScopes c+            $ combineScopes (mkLScope a) (mkLScope b)+          detSpan = case detScope of+            LocalScope a -> Just a+            _ -> Nothing+          toBind (PrefixCon args) = PrefixCon $ map (C Use) args+          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)+          toBind (RecCon r) = RecCon $ map (PSC detSpan) r+      XPatSynBind _ -> []++instance ( ToHie (MatchGroup a (LHsExpr a))+         ) => ToHie (HsPatSynDir a) where+  toHie dir = case dir of+    ExplicitBidirectional mg -> toHie mg+    _ -> pure []++instance ( a ~ GhcPass p+         , ToHie body+         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+         , ToHie (PScoped (LPat a))+         , ToHie (GRHSs a body)+         , Data (Match a body)+         ) => ToHie (LMatch (GhcPass p) body) where+  toHie (L span m ) = concatM $ makeNode m span : case m of+    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->+      [ toHie mctx+      , let rhsScope = mkScope $ grhss_span grhss+          in toHie $ patScopes Nothing rhsScope NoScope pats+      , toHie grhss+      ]+    XMatch _ -> []++instance ( ToHie (Context (Located a))+         ) => ToHie (HsMatchContext a) where+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+  toHie (StmtCtxt a) = toHie a+  toHie _ = pure []++instance ( ToHie (HsMatchContext a)+         ) => ToHie (HsStmtContext a) where+  toHie (PatGuard a) = toHie a+  toHie (ParStmtCtxt a) = toHie a+  toHie (TransStmtCtxt a) = toHie a+  toHie _ = pure []++instance ( a ~ GhcPass p+         , ToHie (Context (Located (IdP a)))+         , ToHie (RContext (HsRecFields a (PScoped (LPat a))))+         , ToHie (LHsExpr a)+         , ToHie (TScoped (LHsSigWcType a))+         , ProtectSig a+         , ToHie (TScoped (ProtectedSig a))+         , HasType (LPat a)+         , Data (HsSplice a)+         ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where+  toHie (PS rsp scope pscope lpat@(L ospan opat)) =+    concatM $ getTypeNode lpat : case opat of+      WildPat _ ->+        []+      VarPat _ lname ->+        [ toHie $ C (PatternBind scope pscope rsp) lname+        ]+      LazyPat _ p ->+        [ toHie $ PS rsp scope pscope p+        ]+      AsPat _ lname pat ->+        [ toHie $ C (PatternBind scope+                                 (combineScopes (mkLScope pat) pscope)+                                 rsp)+                    lname+        , toHie $ PS rsp scope pscope pat+        ]+      ParPat _ pat ->+        [ toHie $ PS rsp scope pscope pat+        ]+      BangPat _ pat ->+        [ toHie $ PS rsp scope pscope pat+        ]+      ListPat _ pats ->+        [ toHie $ patScopes rsp scope pscope pats+        ]+      TuplePat _ pats _ ->+        [ toHie $ patScopes rsp scope pscope pats+        ]+      SumPat _ pat _ _ ->+        [ toHie $ PS rsp scope pscope pat+        ]+      ConPatIn c dets ->+        [ toHie $ C Use c+        , toHie $ contextify dets+        ]+      ConPatOut {pat_con = con, pat_args = dets}->+        [ toHie $ C Use $ fmap conLikeName con+        , toHie $ contextify dets+        ]+      ViewPat _ expr pat ->+        [ toHie expr+        , toHie $ PS rsp scope pscope pat+        ]+      SplicePat _ sp ->+        [ toHie $ L ospan sp+        ]+      LitPat _ _ ->+        []+      NPat _ _ _ _ ->+        []+      NPlusKPat _ n _ _ _ _ ->+        [ toHie $ C (PatternBind scope pscope rsp) n+        ]+      SigPat _ pat sig ->+        [ toHie $ PS rsp scope pscope pat+        , let cscope = mkLScope pat in+            toHie $ TS (ResolvedScopes [cscope, scope, pscope])+                       (protectSig @a cscope sig)+              -- See Note [Scoping Rules for SigPat]+        ]+      CoPat _ _ _ _ ->+        []+      XPat _ -> []+    where+      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args+      contextify (InfixCon a b) = InfixCon a' b'+        where [a', b'] = patScopes rsp scope pscope [a,b]+      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r+      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a+        where+          go (RS fscope (L spn (HsRecField lbl pat pun))) =+            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun+          scoped_fds = listScopes pscope fds++instance ( ToHie body+         , ToHie (LGRHS a body)+         , ToHie (RScoped (LHsLocalBinds a))+         ) => ToHie (GRHSs a body) where+  toHie grhs = concatM $ case grhs of+    GRHSs _ grhss binds ->+     [ toHie grhss+     , toHie $ RS (mkScope $ grhss_span grhs) binds+     ]+    XGRHSs _ -> []++instance ( ToHie (Located body)+         , ToHie (RScoped (GuardLStmt a))+         , Data (GRHS a (Located body))+         ) => ToHie (LGRHS a (Located body)) where+  toHie (L span g) = concatM $ makeNode g span : case g of+    GRHS _ guards body ->+      [ toHie $ listScopes (mkLScope body) guards+      , toHie body+      ]+    XGRHS _ -> []++instance ( a ~ GhcPass p+         , ToHie (Context (Located (IdP a)))+         , HasType (LHsExpr a)+         , ToHie (PScoped (LPat a))+         , ToHie (MatchGroup a (LHsExpr a))+         , ToHie (LGRHS a (LHsExpr a))+         , ToHie (RContext (HsRecordBinds a))+         , ToHie (RFContext (Located (AmbiguousFieldOcc a)))+         , ToHie (ArithSeqInfo a)+         , ToHie (LHsCmdTop a)+         , ToHie (RScoped (GuardLStmt a))+         , ToHie (RScoped (LHsLocalBinds a))+         , ToHie (TScoped (LHsWcType (NoGhcTc a)))+         , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))+         , Data (HsExpr a)+         , Data (HsSplice a)+         , Data (HsTupArg a)+         , Data (AmbiguousFieldOcc a)+         , (HasRealDataConName a)+         ) => ToHie (LHsExpr (GhcPass p)) where+  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of+      HsVar _ (L _ var) ->+        [ toHie $ C Use (L mspan var)+             -- Patch up var location since typechecker removes it+        ]+      HsUnboundVar _ _ ->+        []+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      HsRecFld _ fld ->+        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)+        ]+      HsOverLabel _ _ _ -> []+      HsIPVar _ _ -> []+      HsOverLit _ _ -> []+      HsLit _ _ -> []+      HsLam _ mg ->+        [ toHie mg+        ]+      HsLamCase _ mg ->+        [ toHie mg+        ]+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]+      HsAppType _ expr sig ->+        [ toHie expr+        , toHie $ TS (ResolvedScopes []) sig+        ]+      OpApp _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      NegApp _ a _ ->+        [ toHie a+        ]+      HsPar _ a ->+        [ toHie a+        ]+      SectionL _ a b ->+        [ toHie a+        , toHie b+        ]+      SectionR _ a b ->+        [ toHie a+        , toHie b+        ]+      ExplicitTuple _ args _ ->+        [ toHie args+        ]+      ExplicitSum _ _ _ expr ->+        [ toHie expr+        ]+      HsCase _ expr matches ->+        [ toHie expr+        , toHie matches+        ]+      HsIf _ _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      HsMultiIf _ grhss ->+        [ toHie grhss+        ]+      HsLet _ binds expr ->+        [ toHie $ RS (mkLScope expr) binds+        , toHie expr+        ]+      HsDo _ _ (L ispan stmts) ->+        [ pure $ locOnly ispan+        , toHie $ listScopes NoScope stmts+        ]+      ExplicitList _ _ exprs ->+        [ toHie exprs+        ]+      RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->+        [ toHie $ C Use (getRealDataCon @a mrealcon name)+            -- See Note [Real DataCon Name]+        , toHie $ RC RecFieldAssign $ binds+        ]+      RecordUpd {rupd_expr = expr, rupd_flds = upds}->+        [ toHie expr+        , toHie $ map (RC RecFieldAssign) upds+        ]+      ExprWithTySig _ expr sig ->+        [ toHie expr+        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig+        ]+      ArithSeq _ _ info ->+        [ toHie info+        ]+      HsPragE _ _ expr ->+        [ toHie expr+        ]+      HsProc _ pat cmdtop ->+        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+        , toHie cmdtop+        ]+      HsStatic _ expr ->+        [ toHie expr+        ]+      HsTick _ _ expr ->+        [ toHie expr+        ]+      HsBinTick _ _ _ expr ->+        [ toHie expr+        ]+      HsWrap _ _ a ->+        [ toHie $ L mspan a+        ]+      HsBracket _ b ->+        [ toHie b+        ]+      HsRnBracketOut _ b p ->+        [ toHie b+        , toHie p+        ]+      HsTcBracketOut _ _wrap b p ->+        [ toHie b+        , toHie p+        ]+      HsSpliceE _ x ->+        [ toHie $ L mspan x+        ]+      XExpr _ -> []++instance ( a ~ GhcPass p+         , ToHie (LHsExpr a)+         , Data (HsTupArg a)+         ) => ToHie (LHsTupArg (GhcPass p)) where+  toHie (L span arg) = concatM $ makeNode arg span : case arg of+    Present _ expr ->+      [ toHie expr+      ]+    Missing _ -> []+    XTupArg _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (LHsExpr a)+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (LHsLocalBinds a))+         , ToHie (RScoped (ApplicativeArg a))+         , ToHie (Located body)+         , Data (StmtLR a a (Located body))+         , Data (StmtLR a a (Located (HsExpr a)))+         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+  toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of+      LastStmt _ body _ _ ->+        [ toHie body+        ]+      BindStmt _ pat body _ _ ->+        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat+        , toHie body+        ]+      ApplicativeStmt _ stmts _ ->+        [ concatMapM (toHie . RS scope . snd) stmts+        ]+      BodyStmt _ body _ _ ->+        [ toHie body+        ]+      LetStmt _ binds ->+        [ toHie $ RS scope binds+        ]+      ParStmt _ parstmts _ _ ->+        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->+                          toHie $ listScopes NoScope stmts)+                     parstmts+        ]+      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->+        [ toHie $ listScopes scope stmts+        , toHie using+        , toHie by+        ]+      RecStmt {recS_stmts = stmts} ->+        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts+        ]+      XStmtLR _ -> []++instance ( ToHie (LHsExpr a)+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (HsLocalBinds a)+         ) => ToHie (RScoped (LHsLocalBinds a)) where+  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+      EmptyLocalBinds _ -> []+      HsIPBinds _ _ -> []+      HsValBinds _ valBinds ->+        [ toHie $ RS (combineScopes scope $ mkScope sp)+                      valBinds+        ]+      XHsLocalBindsLR _ -> []++instance ( ToHie (BindContext (LHsBind a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (XXValBindsLR a a))+         ) => ToHie (RScoped (HsValBindsLR a a)) where+  toHie (RS sc v) = concatM $ case v of+    ValBinds _ binds sigs ->+      [ toHie $ fmap (BC RegularBind sc) binds+      , toHie $ fmap (SC (SI BindSig Nothing)) sigs+      ]+    XValBindsLR x -> [ toHie $ RS sc x ]++instance ToHie (RScoped (NHsValBindsLR GhcTc)) where+  toHie (RS sc (NValBinds binds sigs)) = concatM $+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs+    ]+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where+  toHie (RS sc (NValBinds binds sigs)) = concatM $+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs+    ]++instance ( ToHie (RContext (LHsRecField a arg))+         ) => ToHie (RContext (HsRecFields a arg)) where+  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields++instance ( ToHie (RFContext (Located label))+         , ToHie arg+         , HasLoc arg+         , Data label+         , Data arg+         ) => ToHie (RContext (LHsRecField' label arg)) where+  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of+    HsRecField label expr _ ->+      [ toHie $ RFC c (getRealSpan $ loc expr) label+      , toHie expr+      ]++removeDefSrcSpan :: Name -> Name+removeDefSrcSpan n = setNameLoc n noSrcSpan++instance ToHie (RFContext (LFieldOcc GhcRn)) where+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of+    FieldOcc name _ ->+      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)+      ]+    XFieldOcc _ -> []++instance ToHie (RFContext (LFieldOcc GhcTc)) where+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of+    FieldOcc var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    XFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+    Unambiguous name _ ->+      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name+      ]+    Ambiguous _name _ ->+      [ ]+    XAmbiguousFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+    Unambiguous var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    Ambiguous var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    XAmbiguousFieldOcc _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (LHsExpr a)+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (StmtLR a a (Located (HsExpr a)))+         , Data (HsLocalBinds a)+         ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where+  toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM+    [ toHie $ PS Nothing sc NoScope pat+    , toHie expr+    ]+  toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM+    [ toHie $ listScopes NoScope stmts+    , toHie $ PS Nothing sc NoScope pat+    ]+  toHie (RS _ (XApplicativeArg _)) = pure []++instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where+  toHie (PrefixCon args) = toHie args+  toHie (RecCon rec) = toHie rec+  toHie (InfixCon a b) = concatM [ toHie a, toHie b]++instance ( ToHie (LHsCmd a)+         , Data  (HsCmdTop a)+         ) => ToHie (LHsCmdTop a) where+  toHie (L span top) = concatM $ makeNode top span : case top of+    HsCmdTop _ cmd ->+      [ toHie cmd+      ]+    XCmdTop _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (LHsExpr a)+         , ToHie (MatchGroup a (LHsCmd a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (HsCmd a)+         , Data (HsCmdTop a)+         , Data (StmtLR a a (Located (HsCmd a)))+         , Data (HsLocalBinds a)+         , Data (StmtLR a a (Located (HsExpr a)))+         ) => ToHie (LHsCmd (GhcPass p)) where+  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of+      HsCmdArrApp _ a b _ _ ->+        [ toHie a+        , toHie b+        ]+      HsCmdArrForm _ a _ _ cmdtops ->+        [ toHie a+        , toHie cmdtops+        ]+      HsCmdApp _ a b ->+        [ toHie a+        , toHie b+        ]+      HsCmdLam _ mg ->+        [ toHie mg+        ]+      HsCmdPar _ a ->+        [ toHie a+        ]+      HsCmdCase _ expr alts ->+        [ toHie expr+        , toHie alts+        ]+      HsCmdIf _ _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      HsCmdLet _ binds cmd' ->+        [ toHie $ RS (mkLScope cmd') binds+        , toHie cmd'+        ]+      HsCmdDo _ (L ispan stmts) ->+        [ pure $ locOnly ispan+        , toHie $ listScopes NoScope stmts+        ]+      HsCmdWrap _ _ _ -> []+      XCmd _ -> []++instance ToHie (TyClGroup GhcRn) where+  toHie TyClGroup{ group_tyclds = classes+                 , group_roles  = roles+                 , group_kisigs = sigs+                 , group_instds = instances } =+    concatM+    [ toHie classes+    , toHie sigs+    , toHie roles+    , toHie instances+    ]+  toHie (XTyClGroup _) = pure []++instance ToHie (LTyClDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      FamDecl {tcdFam = fdecl} ->+        [ toHie (L span fdecl)+        ]+      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->+        [ toHie $ C (Decl SynDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars+        , toHie typ+        ]+      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->+        [ toHie $ C (Decl DataDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars+        , toHie defn+        ]+        where+          quant_scope = mkLScope $ dd_ctxt defn+          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc+          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn+          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn+          deriv_sc = mkLScope $ dd_derivs defn+      ClassDecl { tcdCtxt = context+                , tcdLName = name+                , tcdTyVars = vars+                , tcdFDs = deps+                , tcdSigs = sigs+                , tcdMeths = meths+                , tcdATs = typs+                , tcdATDefs = deftyps+                } ->+        [ toHie $ C (Decl ClassDec $ getRealSpan span) name+        , toHie context+        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars+        , toHie deps+        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs+        , toHie $ fmap (BC InstanceBind ModuleScope) meths+        , toHie typs+        , concatMapM (pure . locOnly . getLoc) deftyps+        , toHie deftyps+        ]+        where+          context_scope = mkLScope context+          rhs_scope = foldl1' combineScopes $ map mkScope+            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]+      XTyClDecl _ -> []++instance ToHie (LFamilyDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      FamilyDecl _ info name vars _ sig inj ->+        [ toHie $ C (Decl FamDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [rhsSpan]) vars+        , toHie info+        , toHie $ RS injSpan sig+        , toHie inj+        ]+        where+          rhsSpan = sigSpan `combineScopes` injSpan+          sigSpan = mkScope $ getLoc sig+          injSpan = maybe NoScope (mkScope . getLoc) inj+      XFamilyDecl _ -> []++instance ToHie (FamilyInfo GhcRn) where+  toHie (ClosedTypeFamily (Just eqns)) = concatM $+    [ concatMapM (pure . locOnly . getLoc) eqns+    , toHie $ map go eqns+    ]+    where+      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib+  toHie _ = pure []++instance ToHie (RScoped (LFamilyResultSig GhcRn)) where+  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of+      NoSig _ ->+        []+      KindSig _ k ->+        [ toHie k+        ]+      TyVarSig _ bndr ->+        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr+        ]+      XFamilyResultSig _ -> []++instance ToHie (Located (FunDep (Located Name))) where+  toHie (L span fd@(lhs, rhs)) = concatM $+    [ makeNode fd span+    , toHie $ map (C Use) lhs+    , toHie $ map (C Use) rhs+    ]++instance (ToHie rhs, HasLoc rhs)+    => ToHie (TScoped (FamEqn GhcRn rhs)) where+  toHie (TS _ f) = toHie f++instance (ToHie rhs, HasLoc rhs)+    => ToHie (FamEqn GhcRn rhs) where+  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var+    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+    , toHie pats+    , toHie rhs+    ]+    where scope = combineScopes patsScope rhsScope+          patsScope = mkScope (loc pats)+          rhsScope = mkScope (loc rhs)+  toHie (XFamEqn _) = pure []++instance ToHie (LInjectivityAnn GhcRn) where+  toHie (L span ann) = concatM $ makeNode ann span : case ann of+      InjectivityAnn lhs rhs ->+        [ toHie $ C Use lhs+        , toHie $ map (C Use) rhs+        ]++instance ToHie (HsDataDefn GhcRn) where+  toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM+    [ toHie ctx+    , toHie mkind+    , toHie cons+    , toHie derivs+    ]+  toHie (XHsDataDefn _) = pure []++instance ToHie (HsDeriving GhcRn) where+  toHie (L span clauses) = concatM+    [ pure $ locOnly span+    , toHie clauses+    ]++instance ToHie (LHsDerivingClause GhcRn) where+  toHie (L span cl) = concatM $ makeNode cl span : case cl of+      HsDerivingClause _ strat (L ispan tys) ->+        [ toHie strat+        , pure $ locOnly ispan+        , toHie $ map (TS (ResolvedScopes [])) tys+        ]+      XHsDerivingClause _ -> []++instance ToHie (Located (DerivStrategy GhcRn)) where+  toHie (L span strat) = concatM $ makeNode strat span : case strat of+      StockStrategy -> []+      AnyclassStrategy -> []+      NewtypeStrategy -> []+      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]++instance ToHie (Located OverlapMode) where+  toHie (L span _) = pure $ locOnly span++instance ToHie (LConDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ConDeclGADT { con_names = names, con_qvars = qvars+                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names+        , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars+        , toHie ctx+        , toHie args+        , toHie typ+        ]+        where+          rhsScope = combineScopes argsScope tyScope+          ctxScope = maybe NoScope mkLScope ctx+          argsScope = condecl_scope args+          tyScope = mkLScope typ+      ConDeclH98 { con_name = name, con_ex_tvs = qvars+                 , con_mb_cxt = ctx, con_args = dets } ->+        [ toHie $ C (Decl ConDec $ getRealSpan span) name+        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars+        , toHie ctx+        , toHie dets+        ]+        where+          rhsScope = combineScopes ctxScope argsScope+          ctxScope = maybe NoScope mkLScope ctx+          argsScope = condecl_scope dets+      XConDecl _ -> []+    where condecl_scope args = case args of+            PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs+            InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+            RecCon x -> mkLScope x++instance ToHie (Located [LConDeclField GhcRn]) where+  toHie (L span decls) = concatM $+    [ pure $ locOnly span+    , toHie decls+    ]++instance ( HasLoc thing+         , ToHie (TScoped thing)+         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where+  toHie (TS sc (HsIB ibrn a)) = concatM $+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn+      , toHie $ TS sc a+      ]+    where span = loc a+  toHie (TS _ (XHsImplicitBndrs _)) = pure []++instance ( HasLoc thing+         , ToHie (TScoped thing)+         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+  toHie (TS sc (HsWC names a)) = concatM $+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names+      , toHie $ TS sc a+      ]+    where span = loc a+  toHie (TS _ (XHsWildCardBndrs _)) = pure []++instance ToHie (LStandaloneKindSig GhcRn) where+  toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]++instance ToHie (StandaloneKindSig GhcRn) where+  toHie sig = concatM $ case sig of+    StandaloneKindSig _ name typ ->+      [ toHie $ C TyDecl name+      , toHie $ TS (ResolvedScopes []) typ+      ]+    XStandaloneKindSig _ -> []++instance ToHie (SigContext (LSig GhcRn)) where+  toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of+      TypeSig _ names typ ->+        [ toHie $ map (C TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ+        ]+      PatSynSig _ names typ ->+        [ toHie $ map (C TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ+        ]+      ClassOpSig _ _ names typ ->+        [ case styp of+            ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names+            _  -> toHie $ map (C $ TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ+        ]+      IdSig _ _ -> []+      FixSig _ fsig ->+        [ toHie $ L sp fsig+        ]+      InlineSig _ name _ ->+        [ toHie $ (C Use) name+        ]+      SpecSig _ name typs _ ->+        [ toHie $ (C Use) name+        , toHie $ map (TS (ResolvedScopes [])) typs+        ]+      SpecInstSig _ _ typ ->+        [ toHie $ TS (ResolvedScopes []) typ+        ]+      MinimalSig _ _ form ->+        [ toHie form+        ]+      SCCFunSig _ _ name mtxt ->+        [ toHie $ (C Use) name+        , pure $ maybe [] (locOnly . getLoc) mtxt+        ]+      CompleteMatchSig _ _ (L ispan names) typ ->+        [ pure $ locOnly ispan+        , toHie $ map (C Use) names+        , toHie $ fmap (C Use) typ+        ]+      XSig _ -> []++instance ToHie (LHsType GhcRn) where+  toHie x = toHie $ TS (ResolvedScopes []) x++instance ToHie (TScoped (LHsType GhcRn)) where+  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of+      HsForAllTy _ _ bndrs body ->+        [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs+        , toHie body+        ]+      HsQualTy _ ctx body ->+        [ toHie ctx+        , toHie body+        ]+      HsTyVar _ _ var ->+        [ toHie $ C Use var+        ]+      HsAppTy _ a b ->+        [ toHie a+        , toHie b+        ]+      HsAppKindTy _ ty ki ->+        [ toHie ty+        , toHie $ TS (ResolvedScopes []) ki+        ]+      HsFunTy _ a b ->+        [ toHie a+        , toHie b+        ]+      HsListTy _ a ->+        [ toHie a+        ]+      HsTupleTy _ _ tys ->+        [ toHie tys+        ]+      HsSumTy _ tys ->+        [ toHie tys+        ]+      HsOpTy _ a op b ->+        [ toHie a+        , toHie $ C Use op+        , toHie b+        ]+      HsParTy _ a ->+        [ toHie a+        ]+      HsIParamTy _ ip ty ->+        [ toHie ip+        , toHie ty+        ]+      HsKindSig _ a b ->+        [ toHie a+        , toHie b+        ]+      HsSpliceTy _ a ->+        [ toHie $ L span a+        ]+      HsDocTy _ a _ ->+        [ toHie a+        ]+      HsBangTy _ _ ty ->+        [ toHie ty+        ]+      HsRecTy _ fields ->+        [ toHie fields+        ]+      HsExplicitListTy _ _ tys ->+        [ toHie tys+        ]+      HsExplicitTupleTy _ tys ->+        [ toHie tys+        ]+      HsTyLit _ _ -> []+      HsWildCardTy _ -> []+      HsStarTy _ _ -> []+      XHsType _ -> []++instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where+  toHie (HsValArg tm) = toHie tm+  toHie (HsTypeArg _ ty) = toHie ty+  toHie (HsArgPar sp) = pure $ locOnly sp++instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where+  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+      UserTyVar _ var ->+        [ toHie $ C (TyVarBind sc tsc) var+        ]+      KindedTyVar _ var kind ->+        [ toHie $ C (TyVarBind sc tsc) var+        , toHie kind+        ]+      XTyVarBndr _ -> []++instance ToHie (TScoped (LHsQTyVars GhcRn)) where+  toHie (TS sc (HsQTvs implicits vars)) = concatM $+    [ pure $ bindingsOnly bindings+    , toHie $ tvScopes sc NoScope vars+    ]+    where+      varLoc = loc vars+      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits+  toHie (TS _ (XLHsQTyVars _)) = pure []++instance ToHie (LHsContext GhcRn) where+  toHie (L span tys) = concatM $+      [ pure $ locOnly span+      , toHie tys+      ]++instance ToHie (LConDeclField GhcRn) where+  toHie (L span field) = concatM $ makeNode field span : case field of+      ConDeclField _ fields typ _ ->+        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields+        , toHie typ+        ]+      XConDeclField _ -> []++instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where+  toHie (From expr) = toHie expr+  toHie (FromThen a b) = concatM $+    [ toHie a+    , toHie b+    ]+  toHie (FromTo a b) = concatM $+    [ toHie a+    , toHie b+    ]+  toHie (FromThenTo a b c) = concatM $+    [ toHie a+    , toHie b+    , toHie c+    ]++instance ToHie (LSpliceDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      SpliceDecl _ splice _ ->+        [ toHie splice+        ]+      XSpliceDecl _ -> []++instance ToHie (HsBracket a) where+  toHie _ = pure []++instance ToHie PendingRnSplice where+  toHie _ = pure []++instance ToHie PendingTcSplice where+  toHie _ = pure []++instance ToHie (LBooleanFormula (Located Name)) where+  toHie (L span form) = concatM $ makeNode form span : case form of+      Var a ->+        [ toHie $ C Use a+        ]+      And forms ->+        [ toHie forms+        ]+      Or forms ->+        [ toHie forms+        ]+      Parens f ->+        [ toHie f+        ]++instance ToHie (Located HsIPName) where+  toHie (L span e) = makeNode e span++instance ( ToHie (LHsExpr a)+         , Data (HsSplice a)+         ) => ToHie (Located (HsSplice a)) where+  toHie (L span sp) = concatM $ makeNode sp span : case sp of+      HsTypedSplice _ _ _ expr ->+        [ toHie expr+        ]+      HsUntypedSplice _ _ _ expr ->+        [ toHie expr+        ]+      HsQuasiQuote _ _ _ ispan _ ->+        [ pure $ locOnly ispan+        ]+      HsSpliced _ _ _ ->+        []+      HsSplicedT _ ->+        []+      XSplice _ -> []++instance ToHie (LRoleAnnotDecl GhcRn) where+  toHie (L span annot) = concatM $ makeNode annot span : case annot of+      RoleAnnotDecl _ var roles ->+        [ toHie $ C Use var+        , concatMapM (pure . locOnly . getLoc) roles+        ]+      XRoleAnnotDecl _ -> []++instance ToHie (LInstDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ClsInstD _ d ->+        [ toHie $ L span d+        ]+      DataFamInstD _ d ->+        [ toHie $ L span d+        ]+      TyFamInstD _ d ->+        [ toHie $ L span d+        ]+      XInstDecl _ -> []++instance ToHie (LClsInstDecl GhcRn) where+  toHie (L span decl) = concatM+    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl+    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl+    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl+    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl+    , toHie $ cid_tyfam_insts decl+    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl+    , toHie $ cid_datafam_insts decl+    , toHie $ cid_overlap_mode decl+    ]++instance ToHie (LDataFamInstDecl GhcRn) where+  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d++instance ToHie (LTyFamInstDecl GhcRn) where+  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d++instance ToHie (Context a)+         => ToHie (PatSynFieldContext (RecordPatSynField a)) where+  toHie (PSC sp (RecordPatSynField a b)) = concatM $+    [ toHie $ C (RecField RecFieldDecl sp) a+    , toHie $ C Use b+    ]++instance ToHie (LDerivDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      DerivDecl _ typ strat overlap ->+        [ toHie $ TS (ResolvedScopes []) typ+        , toHie strat+        , toHie overlap+        ]+      XDerivDecl _ -> []++instance ToHie (LFixitySig GhcRn) where+  toHie (L span sig) = concatM $ makeNode sig span : case sig of+      FixitySig _ vars _ ->+        [ toHie $ map (C Use) vars+        ]+      XFixitySig _ -> []++instance ToHie (LDefaultDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      DefaultDecl _ typs ->+        [ toHie typs+        ]+      XDefaultDecl _ -> []++instance ToHie (LForeignDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->+        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes []) sig+        , toHie fi+        ]+      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->+        [ toHie $ C Use name+        , toHie $ TS (ResolvedScopes []) sig+        , toHie fe+        ]+      XForeignDecl _ -> []++instance ToHie ForeignImport where+  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $+    [ locOnly a+    , locOnly b+    , locOnly c+    ]++instance ToHie ForeignExport where+  toHie (CExport (L a _) (L b _)) = pure $ concat $+    [ locOnly a+    , locOnly b+    ]++instance ToHie (LWarnDecls GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      Warnings _ _ warnings ->+        [ toHie warnings+        ]+      XWarnDecls _ -> []++instance ToHie (LWarnDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      Warning _ vars _ ->+        [ toHie $ map (C Use) vars+        ]+      XWarnDecl _ -> []++instance ToHie (LAnnDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      HsAnnotation _ _ prov expr ->+        [ toHie prov+        , toHie expr+        ]+      XAnnDecl _ -> []++instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where+  toHie (ValueAnnProvenance a) = toHie $ C Use a+  toHie (TypeAnnProvenance a) = toHie $ C Use a+  toHie ModuleAnnProvenance = pure []++instance ToHie (LRuleDecls GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      HsRules _ _ rules ->+        [ toHie rules+        ]+      XRuleDecls _ -> []++instance ToHie (LRuleDecl GhcRn) where+  toHie (L _ (XRuleDecl _)) = pure []+  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM+        [ makeNode r span+        , pure $ locOnly $ getLoc rname+        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+        , toHie $ map (RS $ mkScope span) bndrs+        , toHie exprA+        , toHie exprB+        ]+    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc+          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+          exprA_sc = mkLScope exprA+          exprB_sc = mkLScope exprB++instance ToHie (RScoped (LRuleBndr GhcRn)) where+  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+      RuleBndr _ var ->+        [ toHie $ C (ValBind RegularBind sc Nothing) var+        ]+      RuleBndrSig _ var typ ->+        [ toHie $ C (ValBind RegularBind sc Nothing) var+        , toHie $ TS (ResolvedScopes [sc]) typ+        ]+      XRuleBndr _ -> []++instance ToHie (LImportDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->+        [ toHie $ IEC Import name+        , toHie $ fmap (IEC ImportAs) as+        , maybe (pure []) goIE hidden+        ]+      XImportDecl _ -> []+    where+      goIE (hiding, (L sp liens)) = concatM $+        [ pure $ locOnly sp+        , toHie $ map (IEC c) liens+        ]+        where+         c = if hiding then ImportHiding else Import++instance ToHie (IEContext (LIE GhcRn)) where+  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of+      IEVar _ n ->+        [ toHie $ IEC c n+        ]+      IEThingAbs _ n ->+        [ toHie $ IEC c n+        ]+      IEThingAll _ n ->+        [ toHie $ IEC c n+        ]+      IEThingWith _ n _ ns flds ->+        [ toHie $ IEC c n+        , toHie $ map (IEC c) ns+        , toHie $ map (IEC c) flds+        ]+      IEModuleContents _ n ->+        [ toHie $ IEC c n+        ]+      IEGroup _ _ _ -> []+      IEDoc _ _ -> []+      IEDocNamed _ _ -> []+      XIE _ -> []++instance ToHie (IEContext (LIEWrappedName Name)) where+  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of+      IEName n ->+        [ toHie $ C (IEThing c) n+        ]+      IEPattern p ->+        [ toHie $ C (IEThing c) p+        ]+      IEType n ->+        [ toHie $ C (IEThing c) n+        ]++instance ToHie (IEContext (Located (FieldLbl Name))) where+  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of+      FieldLabel _ _ n ->+        [ toHie $ C (IEThing c) $ L span n+        ]
+ compiler/GHC/Iface/Ext/Binary.hs view
@@ -0,0 +1,403 @@+{-+Binary serialization for .hie files.+-}+{-# LANGUAGE ScopedTypeVariables #-}+module GHC.Iface.Ext.Binary+   ( readHieFile+   , readHieFileWithVersion+   , HieHeader+   , writeHieFile+   , HieName(..)+   , toHieName+   , HieFileResult(..)+   , hieMagic+   , hieNameOcc+   )+where++import GHC.Settings               ( maybeRead )++import Config                     ( cProjectVersion )+import GhcPrelude+import Binary+import GHC.Iface.Binary           ( getDictFastString )+import FastMutInt+import FastString                 ( FastString )+import Module                     ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply                 ( takeUniqFromSupply )+import Unique+import UniqFM++import qualified Data.Array as A+import Data.IORef+import Data.ByteString            ( ByteString )+import qualified Data.ByteString  as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List                  ( mapAccumR )+import Data.Word                  ( Word8, Word32 )+import Control.Monad              ( replicateM, when )+import System.Directory           ( createDirectoryIfMissing )+import System.FilePath            ( takeDirectory )++import GHC.Iface.Ext.Types++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+  = ExternalName !Module !OccName !SrcSpan+  | LocalName !OccName !SrcSpan+  | KnownKeyName !Unique+  deriving (Eq)++instance Ord HieName where+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+    -- Not actually non deterministic as it is a KnownKey+  compare ExternalName{} _ = LT+  compare LocalName{} ExternalName{} = GT+  compare LocalName{} _ = LT+  compare KnownKeyName{} _ = GT++instance Outputable HieName where+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u++hieNameOcc :: HieName -> OccName+hieNameOcc (ExternalName _ occ _) = occ+hieNameOcc (LocalName occ _) = occ+hieNameOcc (KnownKeyName u) =+  case lookupKnownKeyName u of+    Just n -> nameOccName n+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"+                        (ppr (unpkUnique u))+++data HieSymbolTable = HieSymbolTable+  { hie_symtab_next :: !FastMutInt+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))+  }++data HieDictionary = HieDictionary+  { hie_dict_next :: !FastMutInt -- The next index to use+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+  }++initBinMemSize :: Int+initBinMemSize = 1024*1024++-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+  mapM_ (putByte bh) $ BS.unpack xs+  putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO ()+writeHieFile hie_file_path hiefile = do+  bh0 <- openBinMem initBinMemSize++  -- Write the header: hieHeader followed by the+  -- hieVersion and the GHC version used to generate this file+  mapM_ (putByte bh0) hieMagic+  putBinLine bh0 $ BSC.pack $ show hieVersion+  putBinLine bh0 $ ghcVersion++  -- remember where the dictionary pointer will go+  dict_p_p <- tellBin bh0+  put_ bh0 dict_p_p++  -- remember where the symbol table pointer will go+  symtab_p_p <- tellBin bh0+  put_ bh0 symtab_p_p++  -- Make some initial state+  symtab_next <- newFastMutInt+  writeFastMutInt symtab_next 0+  symtab_map <- newIORef emptyUFM+  let hie_symtab = HieSymbolTable {+                      hie_symtab_next = symtab_next,+                      hie_symtab_map  = symtab_map }+  dict_next_ref <- newFastMutInt+  writeFastMutInt dict_next_ref 0+  dict_map_ref <- newIORef emptyUFM+  let hie_dict = HieDictionary {+                      hie_dict_next = dict_next_ref,+                      hie_dict_map  = dict_map_ref }++  -- put the main thing+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+                                           (putName hie_symtab)+                                           (putFastString hie_dict)+  put_ bh hiefile++  -- write the symtab pointer at the front of the file+  symtab_p <- tellBin bh+  putAt bh symtab_p_p symtab_p+  seekBin bh symtab_p++  -- write the symbol table itself+  symtab_next' <- readFastMutInt symtab_next+  symtab_map'  <- readIORef symtab_map+  putSymbolTable bh symtab_next' symtab_map'++  -- write the dictionary pointer at the front of the file+  dict_p <- tellBin bh+  putAt bh dict_p_p dict_p+  seekBin bh dict_p++  -- write the dictionary itself+  dict_next <- readFastMutInt dict_next_ref+  dict_map  <- readIORef dict_map_ref+  putDictionary bh dict_next dict_map++  -- and send the result to the file+  createDirectoryIfMissing True (takeDirectory hie_file_path)+  writeBinMem bh hie_file_path+  return ()++data HieFileResult+  = HieFileResult+  { hie_file_result_version :: Integer+  , hie_file_result_ghc_version :: ByteString+  , hie_file_result :: HieFile+  }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache))+readHieFileWithVersion readVersion nc file = do+  bh0 <- readBinMem file++  (hieVersion, ghcVersion) <- readHieFileHeader file bh0++  if readVersion (hieVersion, ghcVersion)+  then do+    (hieFile, nc') <- readHieFileContents bh0 nc+    return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc')+  else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)+readHieFile nc file = do++  bh0 <- readBinMem file++  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++  -- Check if the versions match+  when (readHieVersion /= hieVersion) $+    panic $ unwords ["readHieFile: hie file versions don't match for file:"+                    , file+                    , "Expected"+                    , show hieVersion+                    , "but got", show readHieVersion+                    ]+  (hieFile, nc') <- readHieFileContents bh0 nc+  return $ (HieFileResult hieVersion ghcVersion hieFile, nc')++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+  where+    loop acc = do+      char <- get bh :: IO Word8+      if char == 10 -- ASCII newline '\n'+      then return acc+      else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+  -- Read the header+  magic <- replicateM hieMagicLen (get bh0)+  version <- BSC.unpack <$> readBinLine bh0+  case maybeRead version of+    Nothing ->+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+                      , show version+                      ]+    Just readHieVersion -> do+      ghcVersion <- readBinLine bh0++      -- Check if the header is valid+      when (magic /= hieMagic) $+        panic $ unwords ["readHieFileHeader: headers don't match for file:"+                        , file+                        , "Expected"+                        , show hieMagic+                        , "but got", show magic+                        ]+      return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)+readHieFileContents bh0 nc = do++  dict  <- get_dictionary bh0++  -- read the symbol table so we are capable of reading the actual data+  (bh1, nc') <- do+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+                                               (getDictFastString dict)+      (nc', symtab) <- get_symbol_table bh1+      let bh1' = setUserData bh1+               $ newReadState (getSymTabName symtab)+                              (getDictFastString dict)+      return (bh1', nc')++  -- load the actual data+  hiefile <- get bh1+  return (hiefile, nc')+  where+    get_dictionary bin_handle = do+      dict_p <- get bin_handle+      data_p <- tellBin bin_handle+      seekBin bin_handle dict_p+      dict <- getDictionary bin_handle+      seekBin bin_handle data_p+      return dict++    get_symbol_table bh1 = do+      symtab_p <- get bh1+      data_p'  <- tellBin bh1+      seekBin bh1 symtab_p+      (nc', symtab) <- getSymbolTable bh1 nc+      seekBin bh1 data_p'+      return (nc', symtab)++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+                              hie_dict_map  = out_r}  bh f+  = do+    out <- readIORef out_r+    let unique = getUnique f+    case lookupUFM out unique of+        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           put_ bh (fromIntegral j :: Word32)+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+  put_ bh next_off+  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+  mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)+getSymbolTable bh namecache = do+  sz <- get bh+  od_names <- replicateM sz (getHieName bh)+  let arr = A.listArray (0,sz-1) names+      (namecache', names) = mapAccumR fromHieName namecache od_names+  return (namecache', arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+  i :: Word32 <- get bh+  return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+  symmap <- readIORef ref+  case lookupUFM symmap name of+    Just (off, ExternalName mod occ (UnhelpfulSpan _))+      | isGoodSrcSpan (nameSrcSpan name) -> do+      let hieName = ExternalName mod occ (nameSrcSpan name)+      writeIORef ref $! addToUFM symmap name (off, hieName)+      put_ bh (fromIntegral off :: Word32)+    Just (off, LocalName _occ span)+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do+      writeIORef ref $! addToUFM symmap name (off, toHieName name)+      put_ bh (fromIntegral off :: Word32)+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)+    Nothing -> do+        off <- readFastMutInt next+        writeFastMutInt next (off+1)+        writeIORef ref $! addToUFM symmap name (off, toHieName name)+        put_ bh (fromIntegral off :: Word32)++  where+    notLocal :: HieName -> Bool+    notLocal LocalName{} = False+    notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+  | isKnownKeyName name = KnownKeyName (nameUnique name)+  | isExternalName name = ExternalName (nameModule name)+                                       (nameOccName name)+                                       (nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+    let cache = nsNames nc+    in case lookupOrigNameCache cache mod occ of+         Just name -> (nc, name)+         Nothing ->+           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+               name       = mkExternalName uniq mod occ span+               new_cache  = extendNameCache cache mod occ name+           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+        name       = mkInternalName uniq occ span+    in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+    Nothing -> pprPanic "fromHieName:unknown known-key unique"+                        (ppr (unpkUnique u))+    Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+  putByte bh 0+  put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+  putByte bh 1+  put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+  putByte bh 2+  put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+  t <- getByte bh+  case t of+    0 -> do+      (modu, occ, span) <- get bh+      return $ ExternalName modu occ span+    1 -> do+      (occ, span) <- get bh+      return $ LocalName occ span+    2 -> do+      (c,i) <- get bh+      return $ KnownKeyName $ mkUnique c i+    _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag"
+ compiler/GHC/Iface/Ext/Debug.hs view
@@ -0,0 +1,172 @@+{-+Functions to validate and check .hie file ASTs generated by GHC.+-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module GHC.Iface.Ext.Debug where++import GhcPrelude++import SrcLoc+import Module+import FastString+import Outputable++import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Binary+import GHC.Iface.Ext.Utils+import Name++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Function    ( on )+import Data.List        ( sortOn )+import Data.Foldable    ( toList )++ppHies :: Outputable a => (HieASTs a) -> SDoc+ppHies (HieASTs asts) = M.foldrWithKey go "" asts+  where+    go k a rest = vcat $+      [ "File: " <> ppr k+      , ppHie a+      , rest+      ]++ppHie :: Outputable a => HieAST a -> SDoc+ppHie = go 0+  where+    go n (Node inf sp children) = hang header n rest+      where+        rest = vcat $ map (go (n+2)) children+        header = hsep+          [ "Node"+          , ppr sp+          , ppInfo inf+          ]++ppInfo :: Outputable a => NodeInfo a -> SDoc+ppInfo ni = hsep+  [ ppr $ toList $ nodeAnnotations ni+  , ppr $ nodeType ni+  , ppr $ M.toList $ nodeIdentifiers ni+  ]++type Diff a = a -> a -> [SDoc]++diffFile :: Diff HieFile+diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)++diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))+diffAsts f = diffList (diffAst f) `on` M.elems++diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)+diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =+    infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2+  where+    spanDiff+      | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]+      | otherwise = []+    infoDiff'+      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2+     ++ (diffList diffType `on` nodeType) info1 info2+     ++ (diffIdents `on` nodeIdentifiers) info1 info2+    infoDiff = case infoDiff' of+      [] -> []+      xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)+                           , "and", ppr (nodeIdentifiers info2,span2)+                        , "While comparing"+                        , ppr (normalizeIdents $ nodeIdentifiers info1), "and"+                        , ppr (normalizeIdents $ nodeIdentifiers info2)+                        ]+                  ]++    diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b+    diffIdent (a,b) (c,d) = diffName a c+                         ++ eqDiff b d+    diffName (Right a) (Right b) = case (a,b) of+      (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')+      (LocalName o _, ExternalName _ o' _) -> eqDiff o o'+      _ -> eqDiff a b+    diffName a b = eqDiff a b++type DiffIdent = Either ModuleName HieName++normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]+normalizeIdents = sortOn go . map (first toHieName) . M.toList+  where+    first f (a,b) = (fmap f a, b)+    go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)++diffList :: Diff a -> Diff [a]+diffList f xs ys+  | length xs == length ys = concat $ zipWith f xs ys+  | otherwise = ["length of lists doesn't match"]++eqDiff :: (Outputable a, Eq a) => Diff a+eqDiff a b+  | a == b = []+  | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]++validAst :: HieAST a -> Either SDoc ()+validAst (Node _ span children) = do+  checkContainment children+  checkSorted children+  mapM_ validAst children+  where+    checkSorted [] = return ()+    checkSorted [_] = return ()+    checkSorted (x:y:xs)+      | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)+      | otherwise = Left $ hsep+          [ ppr $ nodeSpan x+          , "is not to the left of"+          , ppr $ nodeSpan y+          ]+    checkContainment [] = return ()+    checkContainment (x:xs)+      | span `containsSpan` (nodeSpan x) = checkContainment xs+      | otherwise = Left $ hsep+          [ ppr $ span+          , "does not contain"+          , ppr $ nodeSpan x+          ]++-- | Look for any identifiers which occur outside of their supposed scopes.+-- Returns a list of error messages.+validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]+validateScopes mod asts = validScopes+  where+    refMap = generateReferencesMap asts+    -- We use a refmap for most of the computation++    -- Check if all the names occur in their calculated scopes+    validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap+    valid (Left _) _ = []+    valid (Right n) refs = concatMap inScope refs+      where+        mapRef = foldMap getScopeFromContext . identInfo . snd+        scopes = case foldMap mapRef refs of+          Just xs -> xs+          Nothing -> []+        inScope (sp, dets)+          |  (definedInAsts asts n)+          && any isOccurrence (identInfo dets)+          -- We validate scopes for names which are defined locally, and occur+          -- in this span+            = case scopes of+              [] | (nameIsLocalOrFrom mod n+                   && not (isDerivedOccName $ nameOccName n))+                   -- If we don't get any scopes for a local name then its an error.+                   -- We can ignore derived names.+                   -> return $ hsep $+                     [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp+                     , "Doesn't have a calculated scope: ", ppr scopes]+                 | otherwise -> []+              _ -> if any (`scopeContainsSpan` sp) scopes+                   then []+                   else return $ hsep $+                     [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp+                     , "doesn't occur in calculated scope", ppr scopes]+          | otherwise = []
+ compiler/GHC/Iface/Ext/Types.hs view
@@ -0,0 +1,509 @@+{-+Types for the .hie file format are defined here.++For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files+-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module GHC.Iface.Ext.Types where++import GhcPrelude++import Config+import Binary+import FastString                 ( FastString )+import GHC.Iface.Type+import Module                     ( ModuleName, Module )+import Name                       ( Name )+import Outputable hiding ( (<>) )+import SrcLoc                     ( RealSrcSpan )+import Avail++import qualified Data.Array as A+import qualified Data.Map as M+import qualified Data.Set as S+import Data.ByteString            ( ByteString )+import Data.Data                  ( Typeable, Data )+import Data.Semigroup             ( Semigroup(..) )+import Data.Word                  ( Word8 )+import Control.Applicative        ( (<|>) )++type Span = RealSrcSpan++-- | Current version of @.hie@ files+hieVersion :: Integer+hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer++{- |+GHC builds up a wealth of information about Haskell source as it compiles it.+@.hie@ files are a way of persisting some of this information to disk so that+external tools that need to work with haskell source don't need to parse,+typecheck, and rename all over again. These files contain:++  * a simplified AST++       * nodes are annotated with source positions and types+       * identifiers are annotated with scope information++  * the raw bytes of the initial Haskell source++Besides saving compilation cycles, @.hie@ files also offer a more stable+interface than the GHC API.+-}+data HieFile = HieFile+    { hie_hs_file :: FilePath+    -- ^ Initial Haskell source file path++    , hie_module :: Module+    -- ^ The module this HIE file is for++    , hie_types :: A.Array TypeIndex HieTypeFlat+    -- ^ Types referenced in the 'hie_asts'.+    --+    -- See Note [Efficient serialization of redundant type info]++    , hie_asts :: HieASTs TypeIndex+    -- ^ Type-annotated abstract syntax trees++    , hie_exports :: [AvailInfo]+    -- ^ The names that this module exports++    , hie_hs_src :: ByteString+    -- ^ Raw bytes of the initial Haskell source+    }+instance Binary HieFile where+  put_ bh hf = do+    put_ bh $ hie_hs_file hf+    put_ bh $ hie_module hf+    put_ bh $ hie_types hf+    put_ bh $ hie_asts hf+    put_ bh $ hie_exports hf+    put_ bh $ hie_hs_src hf++  get bh = HieFile+    <$> get bh+    <*> get bh+    <*> get bh+    <*> get bh+    <*> get bh+    <*> get bh+++{-+Note [Efficient serialization of redundant type info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The type information in .hie files is highly repetitive and redundant. For+example, consider the expression++    const True 'a'++There is a lot of shared structure between the types of subterms:++  * const True 'a' ::                 Bool+  * const True     ::         Char -> Bool+  * const          :: Bool -> Char -> Bool++Since all 3 of these types need to be stored in the .hie file, it is worth+making an effort to deduplicate this shared structure. The trick is to define+a new data type that is a flattened version of 'Type':++    data HieType a = HAppTy a a  -- data Type = AppTy Type Type+                   | HFunTy a a  --           | FunTy Type Type+                   | ...++    type TypeIndex = Int++Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',+where the 'TypeIndex's in the 'HieType' are references to other elements of the+array. Types recovered from GHC are deduplicated and stored in this compressed+form with sharing of subtrees.+-}++type TypeIndex = Int++-- | A flattened version of 'Type'.+--+-- See Note [Efficient serialization of redundant type info]+data HieType a+  = HTyVarTy Name+  | HAppTy a (HieArgs a)+  | HTyConApp IfaceTyCon (HieArgs a)+  | HForAllTy ((Name, a),ArgFlag) a+  | HFunTy  a a+  | HQualTy a a           -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')+  | HLitTy IfaceTyLit+  | HCastTy a+  | HCoercionTy+    deriving (Functor, Foldable, Traversable, Eq)++type HieTypeFlat = HieType TypeIndex++-- | Roughly isomorphic to the original core 'Type'.+newtype HieTypeFix = Roll (HieType (HieTypeFix))++instance Binary (HieType TypeIndex) where+  put_ bh (HTyVarTy n) = do+    putByte bh 0+    put_ bh n+  put_ bh (HAppTy a b) = do+    putByte bh 1+    put_ bh a+    put_ bh b+  put_ bh (HTyConApp n xs) = do+    putByte bh 2+    put_ bh n+    put_ bh xs+  put_ bh (HForAllTy bndr a) = do+    putByte bh 3+    put_ bh bndr+    put_ bh a+  put_ bh (HFunTy a b) = do+    putByte bh 4+    put_ bh a+    put_ bh b+  put_ bh (HQualTy a b) = do+    putByte bh 5+    put_ bh a+    put_ bh b+  put_ bh (HLitTy l) = do+    putByte bh 6+    put_ bh l+  put_ bh (HCastTy a) = do+    putByte bh 7+    put_ bh a+  put_ bh (HCoercionTy) = putByte bh 8++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> HTyVarTy <$> get bh+      1 -> HAppTy <$> get bh <*> get bh+      2 -> HTyConApp <$> get bh <*> get bh+      3 -> HForAllTy <$> get bh <*> get bh+      4 -> HFunTy <$> get bh <*> get bh+      5 -> HQualTy <$> get bh <*> get bh+      6 -> HLitTy <$> get bh+      7 -> HCastTy <$> get bh+      8 -> return HCoercionTy+      _ -> panic "Binary (HieArgs Int): invalid tag"+++-- | A list of type arguments along with their respective visibilities (ie. is+-- this an argument that would return 'True' for 'isVisibleArgFlag'?).+newtype HieArgs a = HieArgs [(Bool,a)]+  deriving (Functor, Foldable, Traversable, Eq)++instance Binary (HieArgs TypeIndex) where+  put_ bh (HieArgs xs) = put_ bh xs+  get bh = HieArgs <$> get bh++-- | Mapping from filepaths (represented using 'FastString') to the+-- corresponding AST+newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }+  deriving (Functor, Foldable, Traversable)++instance Binary (HieASTs TypeIndex) where+  put_ bh asts = put_ bh $ M.toAscList $ getAsts asts+  get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)+++data HieAST a =+  Node+    { nodeInfo :: NodeInfo a+    , nodeSpan :: Span+    , nodeChildren :: [HieAST a]+    } deriving (Functor, Foldable, Traversable)++instance Binary (HieAST TypeIndex) where+  put_ bh ast = do+    put_ bh $ nodeInfo ast+    put_ bh $ nodeSpan ast+    put_ bh $ nodeChildren ast++  get bh = Node+    <$> get bh+    <*> get bh+    <*> get bh+++-- | The information stored in one AST node.+--+-- The type parameter exists to provide flexibility in representation of types+-- (see Note [Efficient serialization of redundant type info]).+data NodeInfo a = NodeInfo+    { nodeAnnotations :: S.Set (FastString,FastString)+    -- ^ (name of the AST node constructor, name of the AST node Type)++    , nodeType :: [a]+    -- ^ The Haskell types of this node, if any.++    , nodeIdentifiers :: NodeIdentifiers a+    -- ^ All the identifiers and their details+    } deriving (Functor, Foldable, Traversable)++instance Binary (NodeInfo TypeIndex) where+  put_ bh ni = do+    put_ bh $ S.toAscList $ nodeAnnotations ni+    put_ bh $ nodeType ni+    put_ bh $ M.toList $ nodeIdentifiers ni+  get bh = NodeInfo+    <$> fmap (S.fromDistinctAscList) (get bh)+    <*> get bh+    <*> fmap (M.fromList) (get bh)++type Identifier = Either ModuleName Name++type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)++-- | Information associated with every identifier+--+-- We need to include types with identifiers because sometimes multiple+-- identifiers occur in the same span(Overloaded Record Fields and so on)+data IdentifierDetails a = IdentifierDetails+  { identType :: Maybe a+  , identInfo :: S.Set ContextInfo+  } deriving (Eq, Functor, Foldable, Traversable)++instance Outputable a => Outputable (IdentifierDetails a) where+  ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)++instance Semigroup (IdentifierDetails a) where+  d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)+                               (S.union (identInfo d1) (identInfo d2))++instance Monoid (IdentifierDetails a) where+  mempty = IdentifierDetails Nothing S.empty++instance Binary (IdentifierDetails TypeIndex) where+  put_ bh dets = do+    put_ bh $ identType dets+    put_ bh $ S.toAscList $ identInfo dets+  get bh =  IdentifierDetails+    <$> get bh+    <*> fmap (S.fromDistinctAscList) (get bh)+++-- | Different contexts under which identifiers exist+data ContextInfo+  = Use                -- ^ regular variable+  | MatchBind+  | IEThing IEType     -- ^ import/export+  | TyDecl++  -- | Value binding+  | ValBind+      BindType     -- ^ whether or not the binding is in an instance+      Scope        -- ^ scope over which the value is bound+      (Maybe Span) -- ^ span of entire binding++  -- | Pattern binding+  --+  -- This case is tricky because the bound identifier can be used in two+  -- distinct scopes. Consider the following example (with @-XViewPatterns@)+  --+  -- @+  -- do (b, a, (a -> True)) <- bar+  --    foo a+  -- @+  --+  -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and+  -- in the rest of the @do@-block in @foo a@.+  | PatternBind+      Scope        -- ^ scope /in the pattern/ (the variable bound can be used+                   -- further in the pattern)+      Scope        -- ^ rest of the scope outside the pattern+      (Maybe Span) -- ^ span of entire binding++  | ClassTyDecl (Maybe Span)++  -- | Declaration+  | Decl+      DeclType     -- ^ type of declaration+      (Maybe Span) -- ^ span of entire binding++  -- | Type variable+  | TyVarBind Scope TyVarScope++  -- | Record field+  | RecField RecFieldContext (Maybe Span)+    deriving (Eq, Ord, Show)++instance Outputable ContextInfo where+  ppr = text . show++instance Binary ContextInfo where+  put_ bh Use = putByte bh 0+  put_ bh (IEThing t) = do+    putByte bh 1+    put_ bh t+  put_ bh TyDecl = putByte bh 2+  put_ bh (ValBind bt sc msp) = do+    putByte bh 3+    put_ bh bt+    put_ bh sc+    put_ bh msp+  put_ bh (PatternBind a b c) = do+    putByte bh 4+    put_ bh a+    put_ bh b+    put_ bh c+  put_ bh (ClassTyDecl sp) = do+    putByte bh 5+    put_ bh sp+  put_ bh (Decl a b) = do+    putByte bh 6+    put_ bh a+    put_ bh b+  put_ bh (TyVarBind a b) = do+    putByte bh 7+    put_ bh a+    put_ bh b+  put_ bh (RecField a b) = do+    putByte bh 8+    put_ bh a+    put_ bh b+  put_ bh MatchBind = putByte bh 9++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> return Use+      1 -> IEThing <$> get bh+      2 -> return TyDecl+      3 -> ValBind <$> get bh <*> get bh <*> get bh+      4 -> PatternBind <$> get bh <*> get bh <*> get bh+      5 -> ClassTyDecl <$> get bh+      6 -> Decl <$> get bh <*> get bh+      7 -> TyVarBind <$> get bh <*> get bh+      8 -> RecField <$> get bh <*> get bh+      9 -> return MatchBind+      _ -> panic "Binary ContextInfo: invalid tag"+++-- | Types of imports and exports+data IEType+  = Import+  | ImportAs+  | ImportHiding+  | Export+    deriving (Eq, Enum, Ord, Show)++instance Binary IEType where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data RecFieldContext+  = RecFieldDecl+  | RecFieldAssign+  | RecFieldMatch+  | RecFieldOcc+    deriving (Eq, Enum, Ord, Show)++instance Binary RecFieldContext where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data BindType+  = RegularBind+  | InstanceBind+    deriving (Eq, Ord, Show, Enum)++instance Binary BindType where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data DeclType+  = FamDec     -- ^ type or data family+  | SynDec     -- ^ type synonym+  | DataDec    -- ^ data declaration+  | ConDec     -- ^ constructor declaration+  | PatSynDec  -- ^ pattern synonym+  | ClassDec   -- ^ class declaration+  | InstDec    -- ^ instance declaration+    deriving (Eq, Ord, Show, Enum)++instance Binary DeclType where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data Scope+  = NoScope+  | LocalScope Span+  | ModuleScope+    deriving (Eq, Ord, Show, Typeable, Data)++instance Outputable Scope where+  ppr NoScope = text "NoScope"+  ppr (LocalScope sp) = text "LocalScope" <+> ppr sp+  ppr ModuleScope = text "ModuleScope"++instance Binary Scope where+  put_ bh NoScope = putByte bh 0+  put_ bh (LocalScope span) = do+    putByte bh 1+    put_ bh span+  put_ bh ModuleScope = putByte bh 2++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> return NoScope+      1 -> LocalScope <$> get bh+      2 -> return ModuleScope+      _ -> panic "Binary Scope: invalid tag"+++-- | Scope of a type variable.+--+-- This warrants a data type apart from 'Scope' because of complexities+-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For+-- example, consider:+--+-- @+-- foo, bar, baz :: forall a. a -> a+-- @+--+-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we+-- need a list of scopes to keep track of this. Furthermore, this list cannot be+-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.+--+-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@+-- which later gets resolved into a 'ResolvedScopes'.+data TyVarScope+  = ResolvedScopes [Scope]++  -- | Unresolved scopes should never show up in the final @.hie@ file+  | UnresolvedScope+        [Name]        -- ^ names of the definitions over which the scope spans+        (Maybe Span)  -- ^ the location of the instance/class declaration for+                      -- the case where the type variable is declared in a+                      -- method type signature+    deriving (Eq, Ord)++instance Show TyVarScope where+  show (ResolvedScopes sc) = show sc+  show _ = error "UnresolvedScope"++instance Binary TyVarScope where+  put_ bh (ResolvedScopes xs) = do+    putByte bh 0+    put_ bh xs+  put_ bh (UnresolvedScope ns span) = do+    putByte bh 1+    put_ bh ns+    put_ bh span++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> ResolvedScopes <$> get bh+      1 -> UnresolvedScope <$> get bh <*> get bh+      _ -> panic "Binary TyVarScope: invalid tag"
+ compiler/GHC/Iface/Ext/Utils.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module GHC.Iface.Ext.Utils where++import GhcPrelude++import CoreMap+import DynFlags                   ( DynFlags )+import FastString                 ( FastString, mkFastString )+import GHC.Iface.Type+import Name hiding (varName)+import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )+import SrcLoc+import GHC.CoreToIface+import TyCon+import TyCoRep+import Type+import Var+import VarEnv++import GHC.Iface.Ext.Types++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap.Strict as IM+import qualified Data.Array as A+import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )+import Data.Maybe                 ( maybeToList )+import Data.Monoid+import Data.Traversable           ( for )+import Control.Monad.Trans.State.Strict hiding (get)+++generateReferencesMap+  :: Foldable f+  => f (HieAST a)+  -> M.Map Identifier [(Span, IdentifierDetails a)]+generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty+  where+    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))+      where+        this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast++renderHieType :: DynFlags -> HieTypeFix -> String+renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty+  where sty = defaultUserStyle df++resolveVisibility :: Type -> [Type] -> [(Bool,Type)]+resolveVisibility kind ty_args+  = go (mkEmptyTCvSubst in_scope) kind ty_args+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)++    go _   _                   []     = []+    go env ty                  ts+      | Just ty' <- coreView ty+      = go env ty' ts+    go env (ForAllTy (Bndr tv vis) res) (t:ts)+      | isVisibleArgFlag vis = (True , t) : ts'+      | otherwise            = (False, t) : ts'+      where+        ts' = go (extendTvSubst env tv t) res ts++    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps+      = (True,t) : (go env res ts)++    go env (TyVarTy tv) ts+      | Just ki <- lookupTyVar env tv = go env ki ts+    go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded++foldType :: (HieType a -> a) -> HieTypeFix -> a+foldType f (Roll t) = f $ fmap (foldType f) t++hieTypeToIface :: HieTypeFix -> IfaceType+hieTypeToIface = foldType go+  where+    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n+    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)+    go (HLitTy l) = IfaceLitTy l+    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)+                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t+    go (HFunTy a b)     = IfaceFunTy VisArg   a    b+    go (HQualTy pred b) = IfaceFunTy InvisArg pred b+    go (HCastTy a) = a+    go HCoercionTy = IfaceTyVar "<coercion type>"+    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)++    -- This isn't fully faithful - we can't produce the 'Inferred' case+    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs+    hieToIfaceArgs (HieArgs xs) = go' xs+      where+        go' [] = IA_Nil+        go' ((True ,x):xs) = IA_Arg x Required $ go' xs+        go' ((False,x):xs) = IA_Arg x Specified $ go' xs++data HieTypeState+  = HTS+    { tyMap      :: !(TypeMap TypeIndex)+    , htyTable   :: !(IM.IntMap HieTypeFlat)+    , freshIndex :: !TypeIndex+    }++initialHTS :: HieTypeState+initialHTS = HTS emptyTypeMap IM.empty 0++freshTypeIndex :: State HieTypeState TypeIndex+freshTypeIndex = do+  index <- gets freshIndex+  modify' $ \hts -> hts { freshIndex = index+1 }+  return index++compressTypes+  :: HieASTs Type+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+compressTypes asts = (a, arr)+  where+    (a, (HTS _ m i)) = flip runState initialHTS $+      for asts $ \typ -> do+        i <- getTypeIndex typ+        return i+    arr = A.array (0,i-1) (IM.toList m)++recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix+recoverFullType i m = go i+  where+    go i = Roll $ fmap go (m A.! i)++getTypeIndex :: Type -> State HieTypeState TypeIndex+getTypeIndex t+  | otherwise = do+      tm <- gets tyMap+      case lookupTypeMap tm t of+        Just i -> return i+        Nothing -> do+          ht <- go t+          extendHTS t ht+  where+    extendHTS t ht = do+      i <- freshTypeIndex+      modify' $ \(HTS tm tt fi) ->+        HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi+      return i++    go (TyVarTy v) = return $ HTyVarTy $ varName v+    go ty@(AppTy _ _) = do+      let (head,args) = splitAppTys ty+          visArgs = HieArgs $ resolveVisibility (typeKind head) args+      ai <- getTypeIndex head+      argsi <- mapM getTypeIndex visArgs+      return $ HAppTy ai argsi+    go (TyConApp f xs) = do+      let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs+      is <- mapM getTypeIndex visArgs+      return $ HTyConApp (toIfaceTyCon f) is+    go (ForAllTy (Bndr v a) t) = do+      k <- getTypeIndex (varType v)+      i <- getTypeIndex t+      return $ HForAllTy ((varName v,k),a) i+    go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do+      ai <- getTypeIndex a+      bi <- getTypeIndex b+      return $ case af of+                 InvisArg -> HQualTy ai bi+                 VisArg   -> HFunTy ai bi+    go (LitTy a) = return $ HLitTy $ toIfaceTyLit a+    go (CastTy t _) = do+      i <- getTypeIndex t+      return $ HCastTy i+    go (CoercionTy _) = return HCoercionTy++resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)+resolveTyVarScopes asts = M.map go asts+  where+    go ast = resolveTyVarScopeLocal ast asts++resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a+resolveTyVarScopeLocal ast asts = go ast+  where+    resolveNameScope dets = dets{identInfo =+      S.map resolveScope (identInfo dets)}+    resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =+      TyVarBind sc $ ResolvedScopes+        [ LocalScope binding+        | name <- names+        , Just binding <- [getNameBinding name asts]+        ]+    resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =+      TyVarBind sc $ ResolvedScopes+        [ LocalScope binding+        | name <- names+        , Just binding <- [getNameBindingInClass name sp asts]+        ]+    resolveScope scope = scope+    go (Node info span children) = Node info' span $ map go children+      where+        info' = info { nodeIdentifiers = idents }+        idents = M.map resolveNameScope $ nodeIdentifiers info++getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span+getNameBinding n asts = do+  (_,msp) <- getNameScopeAndBinding n asts+  msp++getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]+getNameScope n asts = do+  (scopes,_) <- getNameScopeAndBinding n asts+  return scopes++getNameBindingInClass+  :: Name+  -> Span+  -> M.Map FastString (HieAST a)+  -> Maybe Span+getNameBindingInClass n sp asts = do+  ast <- M.lookup (srcSpanFile sp) asts+  getFirst $ foldMap First $ do+    child <- flattenAst ast+    dets <- maybeToList+      $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child+    let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+    return (getFirst binding)++getNameScopeAndBinding+  :: Name+  -> M.Map FastString (HieAST a)+  -> Maybe ([Scope], Maybe Span)+getNameScopeAndBinding n asts = case nameSrcSpan n of+  RealSrcSpan sp -> do -- @Maybe+    ast <- M.lookup (srcSpanFile sp) asts+    defNode <- selectLargestContainedBy sp ast+    getFirst $ foldMap First $ do -- @[]+      node <- flattenAst defNode+      dets <- maybeToList+        $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node+      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)+      let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+      return $ Just (scopes, getFirst binding)+  _ -> Nothing++getScopeFromContext :: ContextInfo -> Maybe [Scope]+getScopeFromContext (ValBind _ sc _) = Just [sc]+getScopeFromContext (PatternBind a b _) = Just [a, b]+getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]+getScopeFromContext (Decl _ _) = Just [ModuleScope]+getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs+getScopeFromContext (TyVarBind a _) = Just [a]+getScopeFromContext _ = Nothing++getBindSiteFromContext :: ContextInfo -> Maybe Span+getBindSiteFromContext (ValBind _ _ sp) = sp+getBindSiteFromContext (PatternBind _ _ sp) = sp+getBindSiteFromContext _ = Nothing++flattenAst :: HieAST a -> [HieAST a]+flattenAst n =+  n : concatMap flattenAst (nodeChildren n)++smallestContainingSatisfying+  :: Span+  -> (HieAST a -> Bool)+  -> HieAST a+  -> Maybe (HieAST a)+smallestContainingSatisfying sp cond node+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat+      [ foldMap (First . smallestContainingSatisfying sp cond) $+          nodeChildren node+      , First $ if cond node then Just node else Nothing+      ]+  | sp `containsSpan` nodeSpan node = Nothing+  | otherwise = Nothing++selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)+selectLargestContainedBy sp node+  | sp `containsSpan` nodeSpan node = Just node+  | nodeSpan node `containsSpan` sp =+      getFirst $ foldMap (First . selectLargestContainedBy sp) $+        nodeChildren node+  | otherwise = Nothing++selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)+selectSmallestContaining sp node+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat+      [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node+      , First (Just node)+      ]+  | sp `containsSpan` nodeSpan node = Nothing+  | otherwise = Nothing++definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool+definedInAsts asts n = case nameSrcSpan n of+  RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts+  _ -> False++isOccurrence :: ContextInfo -> Bool+isOccurrence Use = True+isOccurrence _ = False++scopeContainsSpan :: Scope -> Span -> Bool+scopeContainsSpan NoScope _ = False+scopeContainsSpan ModuleScope _ = True+scopeContainsSpan (LocalScope a) b = a `containsSpan` b++-- | One must contain the other. Leaf nodes cannot contain anything+combineAst :: HieAST Type -> HieAST Type -> HieAST Type+combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)+  | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)+  | aSpn `containsSpan` bSpn = combineAst b a+combineAst a (Node xs span children) = Node xs span (insertAst a children)++-- | Insert an AST in a sorted list of disjoint Asts+insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]+insertAst x = mergeAsts [x]++-- | Merge two nodes together.+--+-- Precondition and postcondition: elements in 'nodeType' are ordered.+combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type+(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =+  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)+  where+    mergeSorted :: [Type] -> [Type] -> [Type]+    mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of+                                        LT -> a : mergeSorted as lb+                                        EQ -> a : mergeSorted as bs+                                        GT -> b : mergeSorted la bs+    mergeSorted as [] = as+    mergeSorted [] bs = bs+++{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.++In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),+different nodes in an AST tree should either have disjoint spans (in+which case you can say for sure which one comes first) or one span+should be completely contained in the other (in which case the contained+span corresponds to some child node).++However, since Haskell does have position-altering pragmas it /is/+possible for spans to be overlapping. Here is an example of a source file+in which @foozball@ and @quuuuuux@ have overlapping spans:++@+module Baz where++# line 3 "Baz.hs"+foozball :: Int+foozball = 0++# line 3 "Baz.hs"+bar, quuuuuux :: Int+bar = 1+quuuuuux = 2+@++In these cases, we just do our best to produce sensible `HieAST`'s. The blame+should be laid at the feet of whoever wrote the line pragmas in the first place+(usually the C preprocessor...).+-}+mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]+mergeAsts xs [] = xs+mergeAsts [] ys = ys+mergeAsts xs@(a:as) ys@(b:bs)+  | span_a `containsSpan`   span_b = mergeAsts (combineAst a b : as) bs+  | span_b `containsSpan`   span_a = mergeAsts as (combineAst a b : bs)+  | span_a `rightOf`        span_b = b : mergeAsts xs bs+  | span_a `leftOf`         span_b = a : mergeAsts as ys++  -- These cases are to work around ASTs that are not fully disjoint+  | span_a `startsRightOf`  span_b = b : mergeAsts as ys+  | otherwise                      = a : mergeAsts as ys+  where+    span_a = nodeSpan a+    span_b = nodeSpan b++rightOf :: Span -> Span -> Bool+rightOf s1 s2+  = (srcSpanStartLine s1, srcSpanStartCol s1)+       >= (srcSpanEndLine s2, srcSpanEndCol s2)+    && (srcSpanFile s1 == srcSpanFile s2)++leftOf :: Span -> Span -> Bool+leftOf s1 s2+  = (srcSpanEndLine s1, srcSpanEndCol s1)+       <= (srcSpanStartLine s2, srcSpanStartCol s2)+    && (srcSpanFile s1 == srcSpanFile s2)++startsRightOf :: Span -> Span -> Bool+startsRightOf s1 s2+  = (srcSpanStartLine s1, srcSpanStartCol s1)+       >= (srcSpanStartLine s2, srcSpanStartCol s2)++-- | combines and sorts ASTs using a merge sort+mergeSortAsts :: [HieAST Type] -> [HieAST Type]+mergeSortAsts = go . map pure+  where+    go [] = []+    go [xs] = xs+    go xss = go (mergePairs xss)+    mergePairs [] = []+    mergePairs [xs] = [xs]+    mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss++simpleNodeInfo :: FastString -> FastString -> NodeInfo a+simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty++locOnly :: SrcSpan -> [HieAST a]+locOnly (RealSrcSpan span) =+  [Node e span []]+    where e = NodeInfo S.empty [] M.empty+locOnly _ = []++mkScope :: SrcSpan -> Scope+mkScope (RealSrcSpan sp) = LocalScope sp+mkScope _ = NoScope++mkLScope :: Located a -> Scope+mkLScope = mkScope . getLoc++combineScopes :: Scope -> Scope -> Scope+combineScopes ModuleScope _ = ModuleScope+combineScopes _ ModuleScope = ModuleScope+combineScopes NoScope x = x+combineScopes x NoScope = x+combineScopes (LocalScope a) (LocalScope b) =+  mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)++{-# INLINEABLE makeNode #-}+makeNode+  :: (Applicative m, Data a)+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful+  -> m [HieAST b]+makeNode x spn = pure $ case spn of+  RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]+  _ -> []+  where+    cons = mkFastString . show . toConstr $ x+    typ = mkFastString . show . typeRepTyCon . typeOf $ x++{-# INLINEABLE makeTypeNode #-}+makeTypeNode+  :: (Applicative m, Data a)+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful+  -> Type                    -- ^ type to associate with the node+  -> m [HieAST Type]+makeTypeNode x spn etyp = pure $ case spn of+  RealSrcSpan span ->+    [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]+  _ -> []+  where+    cons = mkFastString . show . toConstr $ x+    typ = mkFastString . show . typeRepTyCon . typeOf $ x
+ compiler/GHC/Iface/Load.hs view
@@ -0,0 +1,1289 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Loading interface files+-}++{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GHC.Iface.Load (+        -- Importing one thing+        tcLookupImported_maybe, importDecl,+        checkWiredInTyCon, ifCheckWiredInThing,++        -- RnM/TcM functions+        loadModuleInterface, loadModuleInterfaces,+        loadSrcInterface, loadSrcInterface_maybe,+        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,++        -- IfM functions+        loadInterface,+        loadSysInterface, loadUserInterface, loadPluginInterface,+        findAndReadIface, readIface,    -- Used when reading the module's old interface+        loadDecls,      -- Should move to GHC.IfaceToCore and be renamed+        initExternalPackageState,+        moduleFreeHolesPrecise,+        needWiredInHomeIface, loadWiredInHomeIface,++        pprModIfaceSimple,+        ifaceStats, pprModIface, showIface+   ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.IfaceToCore+   ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst+   , tcIfaceAnnotations, tcIfaceCompleteSigs )++import DynFlags+import GHC.Iface.Syntax+import GHC.Iface.Env+import HscTypes++import BasicTypes hiding (SuccessFlag(..))+import TcRnMonad++import Constants+import PrelNames+import PrelInfo+import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )+import MkId     ( seqId )+import TysPrim  ( funTyConName )+import Rules+import TyCon+import Annotations+import InstEnv+import FamInstEnv+import Name+import NameEnv+import Avail+import Module+import Maybes+import ErrUtils+import Finder+import UniqFM+import SrcLoc+import Outputable+import GHC.Iface.Binary+import Panic+import Util+import FastString+import Fingerprint+import Hooks+import FieldLabel+import GHC.Iface.Rename+import UniqDSet+import Plugins++import Control.Monad+import Control.Exception+import Data.IORef+import System.FilePath++{-+************************************************************************+*                                                                      *+*      tcImportDecl is the key function for "faulting in"              *+*      imported things+*                                                                      *+************************************************************************++The main idea is this.  We are chugging along type-checking source code, and+find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find+it in the EPS type envt.  So it+        1 loads GHC.Base.hi+        2 gets the decl for GHC.Base.map+        3 typechecks it via tcIfaceDecl+        4 and adds it to the type env in the EPS++Note that DURING STEP 4, we may find that map's type mentions a type+constructor that also++Notice that for imported things we read the current version from the EPS+mutable variable.  This is important in situations like+        ...$(e1)...$(e2)...+where the code that e1 expands to might import some defns that+also turn out to be needed by the code that e2 expands to.+-}++tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+-- Returns (Failed err) if we can't find the interface file for the thing+tcLookupImported_maybe name+  = do  { hsc_env <- getTopEnv+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; case mb_thing of+            Just thing -> return (Succeeded thing)+            Nothing    -> tcImportDecl_maybe name }++tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+-- Entry point for *source-code* uses of importDecl+tcImportDecl_maybe name+  | Just thing <- wiredInNameTyThing_maybe name+  = do  { when (needWiredInHomeIface thing)+               (initIfaceTcRn (loadWiredInHomeIface name))+                -- See Note [Loading instances for wired-in things]+        ; return (Succeeded thing) }+  | otherwise+  = initIfaceTcRn (importDecl name)++importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)+-- Get the TyThing for this Name from an interface file+-- It's not a wired-in thing -- the caller caught that+importDecl name+  = ASSERT( not (isWiredInName name) )+    do  { traceIf nd_doc++        -- Load the interface, which should populate the PTE+        ; mb_iface <- ASSERT2( isExternalName name, ppr name )+                      loadInterface nd_doc (nameModule name) ImportBySystem+        ; case mb_iface of {+                Failed err_msg  -> return (Failed err_msg) ;+                Succeeded _ -> do++        -- Now look it up again; this time we should find it+        { eps <- getEps+        ; case lookupTypeEnv (eps_PTE eps) name of+            Just thing -> return $ Succeeded thing+            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)+                                    $$ not_found_msg+                          in return $ Failed doc+    }}}+  where+    nd_doc = text "Need decl for" <+> ppr name+    not_found_msg = hang (text "Can't find interface-file declaration for" <+>+                                pprNameSpace (nameNameSpace name) <+> ppr name)+                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",+                                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))+      where+        is_interesting thing = nameModule name == nameModule (getName thing)+++{-+************************************************************************+*                                                                      *+           Checks for wired-in things+*                                                                      *+************************************************************************++Note [Loading instances for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to make sure that we have at least *read* the interface files+for any module with an instance decl or RULE that we might want.++* If the instance decl is an orphan, we have a whole separate mechanism+  (loadOrphanModules)++* If the instance decl is not an orphan, then the act of looking at the+  TyCon or Class will force in the defining module for the+  TyCon/Class, and hence the instance decl++* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;+  but we must make sure we read its interface in case it has instances or+  rules.  That is what GHC.Iface.Load.loadWiredInHomeIface does.  It's called+  from GHC.IfaceToCore.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}++* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There+  are some wired-in Ids, but we don't want to load their interfaces. For+  example, Control.Exception.Base.recSelError is wired in, but that module+  is compiled late in the base library, and we don't want to force it to+  load before it's been compiled!++All of this is done by the type checker. The renamer plays no role.+(It used to, but no longer.)+-}++checkWiredInTyCon :: TyCon -> TcM ()+-- Ensure that the home module of the TyCon (and hence its instances)+-- are loaded. See Note [Loading instances for wired-in things]+-- It might not be a wired-in tycon (see the calls in TcUnify),+-- in which case this is a no-op.+checkWiredInTyCon tc+  | not (isWiredInName tc_name)+  = return ()+  | otherwise+  = do  { mod <- getModule+        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)+        ; ASSERT( isExternalName tc_name )+          when (mod /= nameModule tc_name)+               (initIfaceTcRn (loadWiredInHomeIface tc_name))+                -- Don't look for (non-existent) Float.hi when+                -- compiling Float.hs, which mentions Float of course+                -- A bit yukky to call initIfaceTcRn here+        }+  where+    tc_name = tyConName tc++ifCheckWiredInThing :: TyThing -> IfL ()+-- Even though we are in an interface file, we want to make+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)+-- Ditto want to ensure that RULES are loaded too+-- See Note [Loading instances for wired-in things]+ifCheckWiredInThing thing+  = do  { mod <- getIfModule+                -- Check whether we are typechecking the interface for this+                -- very module.  E.g when compiling the base library in --make mode+                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in+                -- the HPT, so without the test we'll demand-load it into the PIT!+                -- C.f. the same test in checkWiredInTyCon above+        ; let name = getName thing+        ; ASSERT2( isExternalName name, ppr name )+          when (needWiredInHomeIface thing && mod /= nameModule name)+               (loadWiredInHomeIface name) }++needWiredInHomeIface :: TyThing -> Bool+-- Only for TyCons; see Note [Loading instances for wired-in things]+needWiredInHomeIface (ATyCon {}) = True+needWiredInHomeIface _           = False+++{-+************************************************************************+*                                                                      *+        loadSrcInterface, loadOrphanModules, loadInterfaceForName++                These three are called from TcM-land+*                                                                      *+************************************************************************+-}++-- | Load the interface corresponding to an @import@ directive in+-- source code.  On a failure, fail in the monad with an error message.+loadSrcInterface :: SDoc+                 -> ModuleName+                 -> IsBootInterface     -- {-# SOURCE #-} ?+                 -> Maybe FastString    -- "package", if any+                 -> RnM ModIface++loadSrcInterface doc mod want_boot maybe_pkg+  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg+       ; case res of+           Failed err      -> failWithTc err+           Succeeded iface -> return iface }++-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.+loadSrcInterface_maybe :: SDoc+                       -> ModuleName+                       -> IsBootInterface     -- {-# SOURCE #-} ?+                       -> Maybe FastString    -- "package", if any+                       -> RnM (MaybeErr MsgDoc ModIface)++loadSrcInterface_maybe doc mod want_boot maybe_pkg+  -- We must first find which Module this import refers to.  This involves+  -- calling the Finder, which as a side effect will search the filesystem+  -- and create a ModLocation.  If successful, loadIface will read the+  -- interface; it will call the Finder again, but the ModLocation will be+  -- cached from the first search.+  = do { hsc_env <- getTopEnv+       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg+       ; case res of+           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)+           -- TODO: Make sure this error message is good+           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }++-- | Load interface directly for a fully qualified 'Module'.  (This is a fairly+-- rare operation, but in particular it is used to load orphan modules+-- in order to pull their instances into the global package table and to+-- handle some operations in GHCi).+loadModuleInterface :: SDoc -> Module -> TcM ModIface+loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)++-- | Load interfaces for a collection of modules.+loadModuleInterfaces :: SDoc -> [Module] -> TcM ()+loadModuleInterfaces doc mods+  | null mods = return ()+  | otherwise = initIfaceTcRn (mapM_ load mods)+  where+    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod++-- | Loads the interface for a given Name.+-- Should only be called for an imported name;+-- otherwise loadSysInterface may not find the interface+loadInterfaceForName :: SDoc -> Name -> TcRn ModIface+loadInterfaceForName doc name+  = do { when debugIsOn $  -- Check pre-condition+         do { this_mod <- getModule+            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }+      ; ASSERT2( isExternalName name, ppr name )+        initIfaceTcRn $ loadSysInterface doc (nameModule name) }++-- | Only loads the interface for external non-local names.+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)+loadInterfaceForNameMaybe doc name+  = do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)+         then return Nothing+         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))+       }++-- | Loads the interface for a given Module.+loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface+loadInterfaceForModule doc m+  = do+    -- Should not be called with this module+    when debugIsOn $ do+      this_mod <- getModule+      MASSERT2( this_mod /= m, ppr m <+> parens doc )+    initIfaceTcRn $ loadSysInterface doc m++{-+*********************************************************+*                                                      *+                loadInterface++        The main function to load an interface+        for an imported module, and put it in+        the External Package State+*                                                      *+*********************************************************+-}++-- | An 'IfM' function to load the home interface for a wired-in thing,+-- so that we're sure that we see its instance declarations and rules+-- See Note [Loading instances for wired-in things]+loadWiredInHomeIface :: Name -> IfM lcl ()+loadWiredInHomeIface name+  = ASSERT( isWiredInName name )+    do _ <- loadSysInterface doc (nameModule name); return ()+  where+    doc = text "Need home interface for wired-in thing" <+> ppr name++------------------+-- | Loads a system interface and throws an exception if it fails+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface+loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem++------------------+-- | Loads a user interface and throws an exception if it fails. The first parameter indicates+-- whether we should import the boot variant of the module+loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface+loadUserInterface is_boot doc mod_name+  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)++loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface+loadPluginInterface doc mod_name+  = loadInterfaceWithException doc mod_name ImportByPlugin++------------------+-- | A wrapper for 'loadInterface' that throws an exception if it fails+loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface+loadInterfaceWithException doc mod_name where_from+  = withException (loadInterface doc mod_name where_from)++------------------+loadInterface :: SDoc -> Module -> WhereFrom+              -> IfM lcl (MaybeErr MsgDoc ModIface)++-- loadInterface looks in both the HPT and PIT for the required interface+-- If not found, it loads it, and puts it in the PIT (always).++-- If it can't find a suitable interface file, we+--      a) modify the PackageIfaceTable to have an empty entry+--              (to avoid repeated complaints)+--      b) return (Left message)+--+-- It's not necessarily an error for there not to be an interface+-- file -- perhaps the module has changed, and that interface+-- is no longer used++loadInterface doc_str mod from+  | isHoleModule mod+  -- Hole modules get special treatment+  = do dflags <- getDynFlags+       -- Redo search for our local hole module+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from+  | otherwise+  = withTimingSilentD (text "loading interface") (pure ()) $+    do  {       -- Read the state+          (eps,hpt) <- getEpsAndHpt+        ; gbl_env <- getGblEnv++        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)++                -- Check whether we have the interface already+        ; dflags <- getDynFlags+        ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {+            Just iface+                -> return (Succeeded iface) ;   -- Already loaded+                        -- The (src_imp == mi_boot iface) test checks that the already-loaded+                        -- interface isn't a boot iface.  This can conceivably happen,+                        -- if an earlier import had a before we got to real imports.   I think.+            _ -> do {++        -- READ THE MODULE IN+        ; read_result <- case (wantHiBootFile dflags eps mod from) of+                           Failed err             -> return (Failed err)+                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod+        ; case read_result of {+            Failed err -> do+                { let fake_iface = emptyFullModIface mod++                ; updateEps_ $ \eps ->+                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }+                        -- Not found, so add an empty iface to+                        -- the EPS map so that we don't look again++                ; return (Failed err) } ;++        -- Found and parsed!+        -- We used to have a sanity check here that looked for:+        --  * System importing ..+        --  * a home package module ..+        --  * that we know nothing about (mb_dep == Nothing)!+        --+        -- But this is no longer valid because thNameToGhcName allows users to+        -- cause the system to load arbitrary interfaces (by supplying an appropriate+        -- Template Haskell original-name).+            Succeeded (iface, loc) ->+        let+            loc_doc = text loc+        in+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do++        dontLeakTheHPT $ do++        --      Load the new ModIface into the External Package State+        -- Even home-package interfaces loaded by loadInterface+        --      (which only happens in OneShot mode; in Batch/Interactive+        --      mode, home-package modules are loaded one by one into the HPT)+        -- are put in the EPS.+        --+        -- The main thing is to add the ModIface to the PIT, but+        -- we also take the+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,+        -- out of the ModIface and put them into the big EPS pools++        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined+        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).+        --     If we do loadExport first the wrong info gets into the cache (unless we+        --      explicitly tag each export which seems a bit of a bore)++        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas+        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)+        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)+        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)+        ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)++        ; let { final_iface = iface {+                                mi_decls     = panic "No mi_decls in PIT",+                                mi_insts     = panic "No mi_insts in PIT",+                                mi_fam_insts = panic "No mi_fam_insts in PIT",+                                mi_rules     = panic "No mi_rules in PIT",+                                mi_anns      = panic "No mi_anns in PIT"+                              }+               }++        ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod+                            -- Warn warn against an EPS-updating import+                            -- of one's own boot file! (one-shot only)+                            -- See Note [Loading your own hi-boot file]+                            -- in GHC.Iface.Utils.++        ; WARN( bad_boot, ppr mod )+          updateEps_  $ \ eps ->+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface+                then eps+           else if bad_boot+                -- See Note [Loading your own hi-boot file]+                then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }+           else+                eps {+                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,+                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,+                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)+                                                        new_eps_rules,+                  eps_complete_matches+                                   = extendCompleteMatchMap+                                         (eps_complete_matches eps)+                                         new_eps_complete_sigs,+                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)+                                                       new_eps_insts,+                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)+                                                          new_eps_fam_insts,+                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)+                                                      new_eps_anns,+                  eps_mod_fam_inst_env+                                   = let+                                       fam_inst_env =+                                         extendFamInstEnvList emptyFamInstEnv+                                                              new_eps_fam_insts+                                     in+                                     extendModuleEnv (eps_mod_fam_inst_env eps)+                                                     mod+                                                     fam_inst_env,+                  eps_stats        = addEpsInStats (eps_stats eps)+                                                   (length new_eps_decls)+                                                   (length new_eps_insts)+                                                   (length new_eps_rules) }++        ; -- invoke plugins+          res <- withPlugins dflags interfaceLoadAction final_iface+        ; return (Succeeded res)+    }}}}++{- Note [Loading your own hi-boot file]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, when compiling module M, we should not+load M.hi boot into the EPS.  After all, we are very shortly+going to have full information about M.  Moreover, see+Note [Do not update EPS with your own hi-boot] in GHC.Iface.Utils.++But there is a HORRIBLE HACK here.++* At the end of tcRnImports, we call checkFamInstConsistency to+  check consistency of imported type-family instances+  See Note [The type family instance consistency story] in FamInst++* Alas, those instances may refer to data types defined in M,+  if there is a M.hs-boot.++* And that means we end up loading M.hi-boot, because those+  data types are not yet in the type environment.++But in this weird case, /all/ we need is the types. We don't need+instances, rules etc.  And if we put the instances in the EPS+we get "duplicate instance" warnings when we compile the "real"+instance in M itself.  Hence the strange business of just updateing+the eps_PTE.++This really happens in practice.  The module HsExpr.hs gets+"duplicate instance" errors if this hack is not present.++This is a mess.+++Note [HPT space leak] (#15111)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In IfL, we defer some work until it is demanded using forkM, such+as building TyThings from IfaceDecls. These thunks are stored in+the ExternalPackageState, and they might never be poked.  If we're+not careful, these thunks will capture the state of the loaded+program when we read an interface file, and retain all that data+for ever.++Therefore, when loading a package interface file , we use a "clean"+version of the HscEnv with all the data about the currently loaded+program stripped out. Most of the fields can be panics because+we'll never read them, but hsc_HPT needs to be empty because this+interface will cause other interfaces to be loaded recursively, and+when looking up those interfaces we use the HPT in loadInterface.+We know that none of the interfaces below here can refer to+home-package modules however, so it's safe for the HPT to be empty.+-}++dontLeakTheHPT :: IfL a -> IfL a+dontLeakTheHPT thing_inside = do+  let+    cleanTopEnv HscEnv{..} =+       let+         -- wrinkle: when we're typechecking in --backpack mode, the+         -- instantiation of a signature might reside in the HPT, so+         -- this case breaks the assumption that EPS interfaces only+         -- refer to other EPS interfaces. We can detect when we're in+         -- typechecking-only mode by using hscTarget==HscNothing, and+         -- in that case we don't empty the HPT.  (admittedly this is+         -- a bit of a hack, better suggestions welcome). A number of+         -- tests in testsuite/tests/backpack break without this+         -- tweak.+         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT+              | otherwise = emptyHomePackageTable+       in+       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"+              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"+              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"+              ,  hsc_HPT          = hpt+              , .. }++  updTopEnv cleanTopEnv $ do+  !_ <- getTopEnv        -- force the updTopEnv+  thing_inside+++-- | Returns @True@ if a 'ModIface' comes from an external package.+-- In this case, we should NOT load it into the EPS; the entities+-- should instead come from the local merged signature interface.+is_external_sig :: DynFlags -> ModIface -> Bool+is_external_sig dflags iface =+    -- It's a signature iface...+    mi_semantic_module iface /= mi_module iface &&+    -- and it's not from the local package+    moduleUnitId (mi_module iface) /= thisPackage dflags++-- | This is an improved version of 'findAndReadIface' which can also+-- handle the case when a user requests @p[A=<B>]:M@ but we only+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.+-- If we are not trying to build code, we load the interface we have,+-- *instantiating it* according to how the holes are specified.+-- (Of course, if we're actually building code, this is a hard error.)+--+-- In the presence of holes, 'computeInterface' has an important invariant:+-- to load module M, its set of transitively reachable requirements must+-- have an up-to-date local hi file for that requirement.  Note that if+-- we are loading the interface of a requirement, this does not+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless+-- we are actually typechecking p.)+computeInterface ::+       SDoc -> IsBootInterface -> Module+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+computeInterface doc_str hi_boot_file mod0 = do+    MASSERT( not (isHoleModule mod0) )+    dflags <- getDynFlags+    case splitModuleInsts mod0 of+        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do+            r <- findAndReadIface doc_str imod mod0 hi_boot_file+            case r of+                Succeeded (iface0, path) -> do+                    hsc_env <- getTopEnv+                    r <- liftIO $+                        rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))+                                   Nothing iface0+                    case r of+                        Right x -> return (Succeeded (x, path))+                        Left errs -> liftIO . throwIO . mkSrcErr $ errs+                Failed err -> return (Failed err)+        (mod, _) ->+            findAndReadIface doc_str mod mod0 hi_boot_file++-- | Compute the signatures which must be compiled in order to+-- load the interface for a 'Module'.  The output of this function+-- is always a subset of 'moduleFreeHoles'; it is more precise+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes+-- are A and B, B might not depend on A at all!+--+-- If this is invoked on a signature, this does NOT include the+-- signature itself; e.g. precise free module holes of+-- @p[A=<A>,B=<B>]:B@ never includes B.+moduleFreeHolesPrecise+    :: SDoc -> Module+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))+moduleFreeHolesPrecise doc_str mod+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)+ | otherwise =+   case splitModuleInsts mod of+    (imod, Just indef) -> do+        let insts = indefUnitIdInsts (indefModuleUnitId indef)+        traceIf (text "Considering whether to load" <+> ppr mod <+>+                 text "to compute precise free module holes")+        (eps, hpt) <- getEpsAndHpt+        case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of+            Just r -> return (Succeeded r)+            Nothing -> readAndCache imod insts+    (_, Nothing) -> return (Succeeded emptyUniqDSet)+  where+    tryEpsAndHpt eps hpt =+        fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod)+    tryDepsCache eps imod insts =+        case lookupInstalledModuleEnv (eps_free_holes eps) imod of+            Just ifhs  -> Just (renameFreeHoles ifhs insts)+            _otherwise -> Nothing+    readAndCache imod insts = do+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False+        case mb_iface of+            Succeeded (iface, _) -> do+                let ifhs = mi_free_holes iface+                -- Cache it+                updateEps_ (\eps ->+                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })+                return (Succeeded (renameFreeHoles ifhs insts))+            Failed err -> return (Failed err)++wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom+               -> MaybeErr MsgDoc IsBootInterface+-- Figure out whether we want Foo.hi or Foo.hi-boot+wantHiBootFile dflags eps mod from+  = case from of+       ImportByUser usr_boot+          | usr_boot && not this_package+          -> Failed (badSourceImport mod)+          | otherwise -> Succeeded usr_boot++       ImportByPlugin+          -> Succeeded False++       ImportBySystem+          | not this_package   -- If the module to be imported is not from this package+          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed+                               -- on the ModuleName of *home-package* modules only.+                               -- We never import boot modules from other packages!++          | otherwise+          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of+                Just (_, is_boot) -> Succeeded is_boot+                Nothing           -> Succeeded False+                     -- The boot-ness of the requested interface,+                     -- based on the dependencies in directly-imported modules+  where+    this_package = thisPackage dflags == moduleUnitId mod++badSourceImport :: Module -> SDoc+badSourceImport mod+  = hang (text "You cannot {-# SOURCE #-} import a module from another package")+       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")+          <+> quotes (ppr (moduleUnitId mod)))++-----------------------------------------------------+--      Loading type/class/value decls+-- We pass the full Module name here, replete with+-- its package info, so that we can build a Name for+-- each binder with the right package info in it+-- All subsequent lookups, including crucially lookups during typechecking+-- the declaration itself, will find the fully-glorious Name+--+-- We handle ATs specially.  They are not main declarations, but also not+-- implicit things (in particular, adding them to `implicitTyThings' would mess+-- things up in the renaming/type checking of source programs).+-----------------------------------------------------++addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv+addDeclsToPTE pte things = extendNameEnvList pte things++loadDecls :: Bool+          -> [(Fingerprint, IfaceDecl)]+          -> IfL [(Name,TyThing)]+loadDecls ignore_prags ver_decls+   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls+        ; return (concat thingss)+        }++loadDecl :: Bool                    -- Don't load pragmas into the decl pool+          -> (Fingerprint, IfaceDecl)+          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the+                                    -- TyThings are forkM'd thunks+loadDecl ignore_prags (_version, decl)+  = do  {       -- Populate the name cache with final versions of all+                -- the names associated with the decl+          let main_name = ifName decl++        -- Typecheck the thing, lazily+        -- NB. Firstly, the laziness is there in case we never need the+        -- declaration (in one-shot mode), and secondly it is there so that+        -- we don't look up the occurrence of a name before calling mk_new_bndr+        -- on the binder.  This is important because we must get the right name+        -- which includes its nameParent.++        ; thing <- forkM doc $ do { bumpDeclStats main_name+                                  ; tcIfaceDecl ignore_prags decl }++        -- Populate the type environment with the implicitTyThings too.+        --+        -- Note [Tricky iface loop]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~+        -- Summary: The delicate point here is that 'mini-env' must be+        -- buildable from 'thing' without demanding any of the things+        -- 'forkM'd by tcIfaceDecl.+        --+        -- In more detail: Consider the example+        --      data T a = MkT { x :: T a }+        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]+        -- (plus their workers, wrappers, coercions etc etc)+        --+        -- We want to return an environment+        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]+        -- (where the "MkT" is the *Name* associated with MkT, etc.)+        --+        -- We do this by mapping the implicit_names to the associated+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and+        -- implicitTyThings, we can use getOccName on the implicit+        -- TyThings to make this association: each Name's OccName should+        -- be the OccName of exactly one implicitTyThing.  So the key is+        -- to define a "mini-env"+        --+        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]+        -- where the 'MkT' here is the *OccName* associated with MkT.+        --+        -- However, there is a subtlety: due to how type checking needs+        -- to be staged, we can't poke on the forkM'd thunks inside the+        -- implicitTyThings while building this mini-env.+        -- If we poke these thunks too early, two problems could happen:+        --    (1) When processing mutually recursive modules across+        --        hs-boot boundaries, poking too early will do the+        --        type-checking before the recursive knot has been tied,+        --        so things will be type-checked in the wrong+        --        environment, and necessary variables won't be in+        --        scope.+        --+        --    (2) Looking up one OccName in the mini_env will cause+        --        others to be looked up, which might cause that+        --        original one to be looked up again, and hence loop.+        --+        -- The code below works because of the following invariant:+        -- getOccName on a TyThing does not force the suspended type+        -- checks in order to extract the name. For example, we don't+        -- poke on the "T a" type of <selector x> on the way to+        -- extracting <selector x>'s OccName. Of course, there is no+        -- reason in principle why getting the OccName should force the+        -- thunks, but this means we need to be careful in+        -- implicitTyThings and its helper functions.+        --+        -- All a bit too finely-balanced for my liking.++        -- This mini-env and lookup function mediates between the+        --'Name's n and the map from 'OccName's to the implicit TyThings+        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]+              lookup n = case lookupOccEnv mini_env (getOccName n) of+                           Just thing -> thing+                           Nothing    ->+                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))++        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)++--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)+        ; return $ (main_name, thing) :+                      -- uses the invariant that implicit_names and+                      -- implicitTyThings are bijective+                      [(n, lookup n) | n <- implicit_names]+        }+  where+    doc = text "Declaration for" <+> ppr (ifName decl)++bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used+bumpDeclStats name+  = do  { traceIf (text "Loading decl for" <+> ppr name)+        ; updateEps_ (\eps -> let stats = eps_stats eps+                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })+        }++{-+*********************************************************+*                                                      *+\subsection{Reading an interface file}+*                                                      *+*********************************************************++Note [Home module load error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the sought-for interface is in the current package (as determined+by -package-name flag) then it jolly well should already be in the HPT+because we process home-package modules in dependency order.  (Except+in one-shot mode; see notes with hsc_HPT decl in HscTypes).++It is possible (though hard) to get this error through user behaviour.+  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,+    Q2, with Q2 importing Q1)+  * We compile both packages.+  * Now we edit package Q so that it somehow depends on P+  * Now recompile Q with --make (without recompiling P).+  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2+    is a home-package module which is not yet in the HPT!  Disaster.++This actually happened with P=base, Q=ghc-prim, via the AMP warnings.+See #8320.+-}++findAndReadIface :: SDoc+                 -- The unique identifier of the on-disk module we're+                 -- looking for+                 -> InstalledModule+                 -- The *actual* module we're looking for.  We use+                 -- this to check the consistency of the requirements+                 -- of the module we read out.+                 -> Module+                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file+                                        -- False <=> Look for .hi file+                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+        -- Nothing <=> file not found, or unreadable, or illegible+        -- Just x  <=> successfully found and parsed++        -- It *doesn't* add an error to the monad, because+        -- sometimes it's ok to fail... see notes with loadInterface+findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file+  = do traceIf (sep [hsep [text "Reading",+                           if hi_boot_file+                             then text "[boot]"+                             else Outputable.empty,+                           text "interface for",+                           ppr mod <> semi],+                     nest 4 (text "reason:" <+> doc_str)])++       -- Check for GHC.Prim, and return its static interface+       -- TODO: make this check a function+       if mod `installedModuleEq` gHC_PRIM+           then do+               iface <- getHooked ghcPrimIfaceHook ghcPrimIface+               return (Succeeded (iface,+                                   "<built in interface for GHC.Prim>"))+           else do+               dflags <- getDynFlags+               -- Look for the file+               hsc_env <- getTopEnv+               mb_found <- liftIO (findExactModule hsc_env mod)+               case mb_found of+                   InstalledFound loc mod -> do+                       -- Found file, so read it+                       let file_path = addBootSuffix_maybe hi_boot_file+                                                           (ml_hi_file loc)++                       -- See Note [Home module load error]+                       if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&+                          not (isOneShot (ghcMode dflags))+                           then return (Failed (homeModError mod loc))+                           else do r <- read_file file_path+                                   checkBuildDynamicToo r+                                   return r+                   err -> do+                       traceIf (text "...not found")+                       dflags <- getDynFlags+                       return (Failed (cannotFindInterface dflags+                                           (installedModuleName mod) err))+    where read_file file_path = do+              traceIf (text "readIFace" <+> text file_path)+              -- Figure out what is recorded in mi_module.  If this is+              -- a fully definite interface, it'll match exactly, but+              -- if it's indefinite, the inside will be uninstantiated!+              dflags <- getDynFlags+              let wanted_mod =+                    case splitModuleInsts wanted_mod_with_insts of+                        (_, Nothing) -> wanted_mod_with_insts+                        (_, Just indef_mod) ->+                          indefModuleToModule dflags+                            (generalizeIndefModule indef_mod)+              read_result <- readIface wanted_mod file_path+              case read_result of+                Failed err -> return (Failed (badIfaceFile file_path err))+                Succeeded iface -> return (Succeeded (iface, file_path))+                            -- Don't forget to fill in the package name...+          checkBuildDynamicToo (Succeeded (iface, filePath)) = do+              dflags <- getDynFlags+              -- Indefinite interfaces are ALWAYS non-dynamic, and+              -- that's OK.+              let is_definite_iface = moduleIsDefinite (mi_module iface)+              when is_definite_iface $+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do+                  let ref = canGenerateDynamicToo dflags+                      dynFilePath = addBootSuffix_maybe hi_boot_file+                                  $ replaceExtension filePath (dynHiSuf dflags)+                  r <- read_file dynFilePath+                  case r of+                      Succeeded (dynIface, _)+                       | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->+                          return ()+                       | otherwise ->+                          do traceIf (text "Dynamic hash doesn't match")+                             liftIO $ writeIORef ref False+                      Failed err ->+                          do traceIf (text "Failed to load dynamic interface file:" $$ err)+                             liftIO $ writeIORef ref False+          checkBuildDynamicToo _ = return ()++-- @readIface@ tries just the one file.++readIface :: Module -> FilePath+          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)+        -- Failed err    <=> file not found, or unreadable, or illegible+        -- Succeeded iface <=> successfully found and parsed++readIface wanted_mod file_path+  = do  { res <- tryMostM $+                 readBinIface CheckHiWay QuietBinIFaceReading file_path+        ; dflags <- getDynFlags+        ; case res of+            Right iface+                -- NB: This check is NOT just a sanity check, it is+                -- critical for correctness of recompilation checking+                -- (it lets us tell when -this-unit-id has changed.)+                | wanted_mod == actual_mod+                                -> return (Succeeded iface)+                | otherwise     -> return (Failed err)+                where+                  actual_mod = mi_module iface+                  err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod++            Left exn    -> return (Failed (text (showException exn)))+    }++{-+*********************************************************+*                                                       *+        Wired-in interface for GHC.Prim+*                                                       *+*********************************************************+-}++initExternalPackageState :: ExternalPackageState+initExternalPackageState+  = EPS {+      eps_is_boot          = emptyUFM,+      eps_PIT              = emptyPackageIfaceTable,+      eps_free_holes       = emptyInstalledModuleEnv,+      eps_PTE              = emptyTypeEnv,+      eps_inst_env         = emptyInstEnv,+      eps_fam_inst_env     = emptyFamInstEnv,+      eps_rule_base        = mkRuleBase builtinRules,+        -- Initialise the EPS rule pool with the built-in rules+      eps_mod_fam_inst_env+                           = emptyModuleEnv,+      eps_complete_matches = emptyUFM,+      eps_ann_env          = emptyAnnEnv,+      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0+                           , n_insts_in = 0, n_insts_out = 0+                           , n_rules_in = length builtinRules, n_rules_out = 0 }+    }++{-+*********************************************************+*                                                       *+        Wired-in interface for GHC.Prim+*                                                       *+*********************************************************+-}++ghcPrimIface :: ModIface+ghcPrimIface+  = empty_iface {+        mi_exports  = ghcPrimExports,+        mi_decls    = [],+        mi_fixities = fixities,+        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }+        }+  where+    empty_iface = emptyFullModIface gHC_PRIM++    -- The fixities listed here for @`seq`@ or @->@ should match+    -- those in primops.txt.pp (from which Haddock docs are generated).+    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)+             : (occName funTyConName, funTyFixity)  -- trac #10145+             : mapMaybe mkFixity allThePrimOps+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op++{-+*********************************************************+*                                                      *+\subsection{Statistics}+*                                                      *+*********************************************************+-}++ifaceStats :: ExternalPackageState -> SDoc+ifaceStats eps+  = hcat [text "Renamer stats: ", msg]+  where+    stats = eps_stats eps+    msg = vcat+        [int (n_ifaces_in stats) <+> text "interfaces read",+         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",+                int (n_decls_in stats), text "read"],+         hsep [ int (n_insts_out stats), text "instance decls imported, out of",+                int (n_insts_in stats), text "read"],+         hsep [ int (n_rules_out stats), text "rule decls imported, out of",+                int (n_rules_in stats), text "read"]+        ]++{-+************************************************************************+*                                                                      *+                Printing interfaces+*                                                                      *+************************************************************************++Note [Name qualification with --show-iface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In order to disambiguate between identifiers from different modules, we qualify+all names that don't originate in the current module. In order to keep visual+noise as low as possible, we keep local names unqualified.++For some background on this choice see trac #15269.+-}++-- | Read binary interface, and print it out+showIface :: HscEnv -> FilePath -> IO ()+showIface hsc_env filename = do+   -- skip the hi way check; we don't want to worry about profiled vs.+   -- non-profiled interfaces, for example.+   iface <- initTcRnIf 's' hsc_env () () $+       readBinIface IgnoreHiWay TraceBinIFaceReading filename+   let dflags = hsc_dflags hsc_env+       -- See Note [Name qualification with --show-iface]+       qualifyImportedNames mod _+           | mod == mi_module iface = NameUnqual+           | otherwise              = NameNotInScope1+       print_unqual = QueryQualify qualifyImportedNames+                                   neverQualifyModules+                                   neverQualifyPackages+   putLogMsg dflags NoReason SevDump noSrcSpan+      (mkDumpStyle dflags print_unqual) (pprModIface iface)++-- Show a ModIface but don't display details; suitable for ModIfaces stored in+-- the EPT.+pprModIfaceSimple :: ModIface -> SDoc+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))++pprModIface :: ModIface -> SDoc+-- Show a ModIface+pprModIface iface@ModIface{ mi_final_exts = exts }+ = vcat [ text "interface"+                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)+                <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)+                <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)+                <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)+                <+> integer hiVersion+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts))+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts))+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts))+        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))+        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))+        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))+        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))+        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))+        , nest 2 (text "where")+        , text "exports:"+        , nest 2 (vcat (map pprExport (mi_exports iface)))+        , pprDeps (mi_deps iface)+        , vcat (map pprUsage (mi_usages iface))+        , vcat (map pprIfaceAnnotation (mi_anns iface))+        , pprFixities (mi_fixities iface)+        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]+        , vcat (map ppr (mi_insts iface))+        , vcat (map ppr (mi_fam_insts iface))+        , vcat (map ppr (mi_rules iface))+        , ppr (mi_warns iface)+        , pprTrustInfo (mi_trust iface)+        , pprTrustPkg (mi_trust_pkg iface)+        , vcat (map ppr (mi_complete_sigs iface))+        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))+        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))+        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))+        ]+  where+    pp_hsc_src HsBootFile = text "[boot]"+    pp_hsc_src HsigFile = text "[hsig]"+    pp_hsc_src HsSrcFile = Outputable.empty++{-+When printing export lists, we print like this:+        Avail   f               f+        AvailTC C [C, x, y]     C(x,y)+        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C+-}++pprExport :: IfaceExport -> SDoc+pprExport (Avail n)         = ppr n+pprExport (AvailTC _ [] []) = Outputable.empty+pprExport (AvailTC n ns0 fs)+  = case ns0 of+      (n':ns) | n==n' -> ppr n <> pp_export ns fs+      _               -> ppr n <> vbar <> pp_export ns0 fs+  where+    pp_export []    [] = Outputable.empty+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))++pprUsage :: Usage -> SDoc+pprUsage usage@UsagePackageModule{}+  = pprUsageImport usage usg_mod+pprUsage usage@UsageHomeModule{}+  = pprUsageImport usage usg_mod_name $$+    nest 2 (+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$+        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]+        )+pprUsage usage@UsageFile{}+  = hsep [text "addDependentFile",+          doubleQuotes (text (usg_file_path usage)),+          ppr (usg_file_hash usage)]+pprUsage usage@UsageMergedRequirement{}+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]++pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc+pprUsageImport usage usg_mod'+  = hsep [text "import", safe, ppr (usg_mod' usage),+                       ppr (usg_mod_hash usage)]+    where+        safe | usg_safe usage = text "safe"+             | otherwise      = text " -/ "++pprDeps :: Dependencies -> SDoc+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,+                dep_finsts = finsts })+  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),+          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),+          text "orphans:" <+> fsep (map ppr orphs),+          text "family instance modules:" <+> fsep (map ppr finsts)+        ]+  where+    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot+    ppr_pkg (pkg,trust_req)  = ppr pkg <>+                               (if trust_req then text "*" else Outputable.empty)+    ppr_boot True  = text "[boot]"+    ppr_boot False = Outputable.empty++pprFixities :: [(OccName, Fixity)] -> SDoc+pprFixities []    = Outputable.empty+pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes+                  where+                    pprFix (occ,fix) = ppr fix <+> ppr occ++pprTrustInfo :: IfaceTrustInfo -> SDoc+pprTrustInfo trust = text "trusted:" <+> ppr trust++pprTrustPkg :: Bool -> SDoc+pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg++instance Outputable Warnings where+    ppr = pprWarns++pprWarns :: Warnings -> SDoc+pprWarns NoWarnings         = Outputable.empty+pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt+pprWarns (WarnSome prs) = text "Warnings"+                        <+> vcat (map pprWarning prs)+    where pprWarning (name, txt) = ppr name <+> ppr txt++pprIfaceAnnotation :: IfaceAnnotation -> SDoc+pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })+  = ppr target <+> text "annotated by" <+> ppr serialized++{-+*********************************************************+*                                                       *+\subsection{Errors}+*                                                       *+*********************************************************+-}++badIfaceFile :: String -> SDoc -> SDoc+badIfaceFile file err+  = vcat [text "Bad interface file:" <+> text file,+          nest 4 err]++hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc+hiModuleNameMismatchWarn dflags requested_mod read_mod+ | moduleUnitId requested_mod == moduleUnitId read_mod =+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,+         text "but we were expecting module" <+> quotes (ppr requested_mod),+         sep [text "Probable cause: the source code which generated interface file",+             text "has an incompatible module name"+            ]+        ]+ | otherwise =+  -- ToDo: This will fail to have enough qualification when the package IDs+  -- are the same+  withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $+    -- we want the Modules below to be qualified with package names,+    -- so reset the PrintUnqualified setting.+    hsep [ text "Something is amiss; requested module "+         , ppr requested_mod+         , text "differs from name found in the interface file"+         , ppr read_mod+         , parens (text "if these names look the same, try again with -dppr-debug")+         ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+  = text "attempting to use module " <> quotes (ppr mod)+    <> (case ml_hs_file location of+           Just file -> space <> parens (text file)+           Nothing   -> Outputable.empty)+    <+> text "which is not loaded"
+ compiler/GHC/Iface/Load.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Iface.Load where++import Module (Module)+import TcRnMonad (IfM)+import HscTypes (ModIface)+import Outputable (SDoc)++loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+ compiler/GHC/Iface/Rename.hs view
@@ -0,0 +1,745 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | This module implements interface renaming, which is+-- used to rewrite interface files on the fly when we+-- are doing indefinite typechecking and need instantiations+-- of modules which do not necessarily exist yet.++module GHC.Iface.Rename (+    rnModIface,+    rnModExports,+    tcRnModIface,+    tcRnModExports,+    ) where++#include "HsVersions.h"++import GhcPrelude++import SrcLoc+import Outputable+import HscTypes+import Module+import UniqFM+import Avail+import GHC.Iface.Syntax+import FieldLabel+import Var+import ErrUtils++import Name+import TcRnMonad+import Util+import Fingerprint+import BasicTypes++-- a bit vexing+import {-# SOURCE #-} GHC.Iface.Load+import DynFlags++import qualified Data.Traversable as T++import Bag+import Data.IORef+import NameShape+import GHC.Iface.Env++tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a+tcRnMsgMaybe do_this = do+    r <- liftIO $ do_this+    case r of+        Left errs -> do+            addMessages (emptyBag, errs)+            failM+        Right x -> return x++tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface+tcRnModIface x y z = do+    hsc_env <- getTopEnv+    tcRnMsgMaybe $ rnModIface hsc_env x y z++tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]+tcRnModExports x y = do+    hsc_env <- getTopEnv+    tcRnMsgMaybe $ rnModExports hsc_env x y++failWithRn :: SDoc -> ShIfM a+failWithRn doc = do+    errs_var <- fmap sh_if_errs getGblEnv+    dflags <- getDynFlags+    errs <- readTcRef errs_var+    -- TODO: maybe associate this with a source location?+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)+    failM++-- | What we have is a generalized ModIface, which corresponds to+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load+-- up (either to merge it, or to just use during typechecking).+--+-- Suppose we have:+--+--  p[A=<A>]:M  ==>  p[A=q():A]:M+--+-- Substitute all occurrences of <A> with q():A (renameHoleModule).+-- Then, for any Name of form {A.T}, replace the Name with+-- the Name according to the exports of the implementing module.+-- This works even for p[A=<B>]:M, since we just read in the+-- exports of B.hi, which is assumed to be ready now.+--+-- This function takes an optional 'NameShape', which can be used+-- to further refine the identities in this interface: suppose+-- we read a declaration for {H.T} but we actually know that this+-- should be Foo.T; then we'll also rename this (this is used+-- when loading an interface to merge it into a requirement.)+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape+           -> ModIface -> IO (Either ErrorMessages ModIface)+rnModIface hsc_env insts nsubst iface = do+    initRnIface hsc_env iface insts nsubst $ do+        mod <- rnModule (mi_module iface)+        sig_of <- case mi_sig_of iface of+                    Nothing -> return Nothing+                    Just x  -> fmap Just (rnModule x)+        exports <- mapM rnAvailInfo (mi_exports iface)+        decls <- mapM rnIfaceDecl' (mi_decls iface)+        insts <- mapM rnIfaceClsInst (mi_insts iface)+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)+        deps <- rnDependencies (mi_deps iface)+        -- TODO:+        -- mi_rules+        return iface { mi_module = mod+                     , mi_sig_of = sig_of+                     , mi_insts = insts+                     , mi_fam_insts = fams+                     , mi_exports = exports+                     , mi_decls = decls+                     , mi_deps = deps }++-- | Rename just the exports of a 'ModIface'.  Useful when we're doing+-- shaping prior to signature merging.+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])+rnModExports hsc_env insts iface+    = initRnIface hsc_env iface insts Nothing+    $ 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 }++rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]+rnDepModules sel deps = 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+        dflags <- getDynFlags+        -- 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+        -- F, we must grab and include all of the dep_finsts from+        -- F to have an accurate transitive dep_finsts list.+        --+        -- However, we MUST NOT do this for regular modules.+        -- First, for efficiency reasons, doing this+        -- bloats the the dep_finsts list, because we *already* had+        -- those modules in the list (it wasn't a hole module, after+        -- all). But there's a second, more important correctness+        -- consideration: we perform module renaming when running+        -- --abi-hash.  In this case, GHC's contract to the user is that+        -- it will NOT go and read out interfaces of any dependencies+        -- (https://github.com/haskell/cabal/issues/3633); the point of+        -- --abi-hash is just to get a hash of the on-disk interfaces+        -- for this *specific* package.  If we go off and tug on the+        -- interface for /everything/ in dep_finsts, we're gonna have a+        -- bad time.  (It's safe to do do this for hole modules, though,+        -- because the hmap for --abi-hash is always trivial, so the+        -- interface we request is local.  Though, maybe we ought+        -- not to do it in this case either...)+        --+        -- This mistake was bug #15594.+        let mod' = renameHoleModule dflags hmap mod+        if isHoleModule mod+          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env+                                  $ loadSysInterface (text "rnDepModule") mod'+                  return (mod' : sel (mi_deps iface))+          else return [mod']++{-+************************************************************************+*                                                                      *+                        ModIface substitution+*                                                                      *+************************************************************************+-}++-- | Run a computation in the 'ShIfM' monad.+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape+            -> ShIfM a -> IO (Either ErrorMessages a)+initRnIface hsc_env iface insts nsubst do_this = do+    errs_var <- newIORef emptyBag+    let dflags = hsc_dflags hsc_env+        hsubst = listToUFM insts+        rn_mod = renameHoleModule dflags hsubst+        env = ShIfEnv {+            sh_if_module = rn_mod (mi_module iface),+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),+            sh_if_hole_subst = listToUFM insts,+            sh_if_shape = nsubst,+            sh_if_errs = errs_var+        }+    -- Modeled off of 'initTc'+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this+    msgs <- readIORef errs_var+    case res of+        Left _                          -> return (Left msgs)+        Right r | not (isEmptyBag msgs) -> return (Left msgs)+                | otherwise             -> return (Right r)++-- | Environment for 'ShIfM' monads.+data ShIfEnv = ShIfEnv {+        -- What we are renaming the ModIface to.  It assumed that+        -- the original mi_module of the ModIface is+        -- @generalizeModule (mi_module iface)@.+        sh_if_module :: Module,+        -- The semantic module that we are renaming to+        sh_if_semantic_module :: Module,+        -- Cached hole substitution, e.g.+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@+        sh_if_hole_subst :: ShHoleSubst,+        -- An optional name substitution to be applied when renaming+        -- the names in the interface.  If this is 'Nothing', then+        -- we just load the target interface and look at the export+        -- list to determine the renaming.+        sh_if_shape :: Maybe NameShape,+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')+        sh_if_errs :: IORef ErrorMessages+    }++getHoleSubst :: ShIfM ShHoleSubst+getHoleSubst = fmap sh_if_hole_subst getGblEnv++type ShIfM = TcRnIf ShIfEnv ()+type Rename a = a -> ShIfM a+++rnModule :: Rename Module+rnModule mod = do+    hmap <- getHoleSubst+    dflags <- getDynFlags+    return (renameHoleModule dflags hmap mod)++rnAvailInfo :: Rename AvailInfo+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n+rnAvailInfo (AvailTC n ns fs) = do+    -- Why don't we rnIfaceGlobal the availName itself?  It may not+    -- actually be exported by the module it putatively is from, in+    -- which case we won't be able to tell what the name actually+    -- is.  But for the availNames they MUST be exported, so they+    -- will rename fine.+    ns' <- mapM rnIfaceGlobal ns+    fs' <- mapM rnFieldLabel fs+    case ns' ++ map flSelector fs' of+        [] -> panic "rnAvailInfoEmpty AvailInfo"+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do+                         n' <- setNameModule (Just (nameModule rep)) n+                         return (AvailTC n' ns' fs')++rnFieldLabel :: Rename FieldLabel+rnFieldLabel (FieldLabel l b sel) = do+    sel' <- rnIfaceGlobal sel+    return (FieldLabel l b sel')+++++-- | The key function.  This gets called on every Name embedded+-- inside a ModIface.  Our job is to take a Name from some+-- generalized unit ID p[A=<A>, B=<B>], and change+-- it to the correct name for a (partially) instantiated unit+-- ID, e.g. p[A=q[]:A, B=<B>].+--+-- There are two important things to do:+--+-- If a hole is substituted with a real module implementation,+-- we need to look at that actual implementation to determine what+-- the true identity of this name should be.  We'll do this by+-- loading that module's interface and looking at the mi_exports.+--+-- However, there is one special exception: when we are loading+-- the interface of a requirement.  In this case, we may not have+-- the "implementing" interface, because we are reading this+-- interface precisely to "merge it in".+--+--     External case:+--         p[A=<B>]:A (and thisUnitId is something else)+--     We are loading this in order to determine B.hi!  So+--     don't load B.hi to find the exports.+--+--     Local case:+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])+--     This should not happen, because the rename is not necessary+--     in this case, but if it does we shouldn't load A.hi!+--+-- Compare me with 'tcIfaceGlobal'!++-- In effect, this function needs compute the name substitution on the+-- fly.  What it has is the name that we would like to substitute.+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then+-- no renaming can take place (although the inner hole structure must+-- be updated to account for the hole module renaming.)+rnIfaceGlobal :: Name -> ShIfM Name+rnIfaceGlobal n = do+    hsc_env <- getTopEnv+    let dflags = hsc_dflags hsc_env+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv+    mb_nsubst <- fmap sh_if_shape getGblEnv+    hmap <- getHoleSubst+    let m = nameModule n+        m' = renameHoleModule dflags hmap m+    case () of+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,+       -- do NOT assume B.hi is available.+       -- In this case, rename {A.T} to {B.T} but don't look up exports.+     _ | m' == iface_semantic_mod+       , isHoleModule m'+      -- NB: this could be Nothing for computeExports, we have+      -- nothing to say.+      -> do n' <- setNameModule (Just m') n+            case mb_nsubst of+                Nothing -> return n'+                Just nsubst ->+                    case maybeSubstNameShape nsubst n' of+                        -- TODO: would love to have context+                        -- TODO: This will give an unpleasant message if n'+                        -- is a constructor; then we'll suggest adding T+                        -- but it won't work.+                        Nothing -> failWithRn $ vcat [+                            text "The identifier" <+> ppr (occName n') <+>+                                text "does not exist in the local signature.",+                            parens (text "Try adding it to the export list of the hsig file.")+                            ]+                        Just n'' -> return n''+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the+       -- export list is irrelevant.+       | not (isHoleModule m)+      -> setNameModule (Just m') n+       -- The substitution was from <A> to p[]:A.+       -- But this does not mean {A.T} goes to p[]:A.T:+       -- p[]:A may reexport T from somewhere else.  Do the name+       -- substitution.  Furthermore, we need+       -- to make sure we pick the accurate name NOW,+       -- or we might accidentally reject a merge.+       | otherwise+      -> do -- Make sure we look up the local interface if substitution+            -- went from <A> to <B>.+            let m'' = if isHoleModule m'+                        -- Pull out the local guy!!+                        then mkModule (thisPackage dflags) (moduleName m')+                        else m'+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env+                            $ loadSysInterface (text "rnIfaceGlobal") m''+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)+            case maybeSubstNameShape nsubst n of+                Nothing -> failWithRn $ vcat [+                    text "The identifier" <+> ppr (occName n) <+>+                        -- NB: report m' because it's more user-friendly+                        text "does not exist in the signature for" <+> ppr m',+                    parens (text "Try adding it to the export list in that hsig file.")+                    ]+                Just n' -> return n'++-- | Rename an implicit name, e.g., a DFun or coercion axiom.+-- Here is where we ensure that DFuns have the correct module as described in+-- Note [rnIfaceNeverExported].+rnIfaceNeverExported :: Name -> ShIfM Name+rnIfaceNeverExported name = do+    hmap <- getHoleSubst+    dflags <- getDynFlags+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv+    let m = renameHoleModule dflags hmap $ nameModule name+    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )+    setNameModule (Just m) name++-- Note [rnIfaceNeverExported]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the high-level overview, see+-- Note [Handling never-exported TyThings under Backpack]+--+-- When we see a reference to an entity that was defined in a signature,+-- 'rnIfaceGlobal' relies on the identifier in question being part of the+-- exports of the implementing 'ModIface', so that we can use the exports to+-- decide how to rename the identifier.  Unfortunately, references to 'DFun's+-- and 'CoAxiom's will run into trouble under this strategy, because they are+-- never exported.+--+-- Let us consider first what should happen in the absence of promotion.  In+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside+-- the signature *that is defining it* (as there are no Core terms in+-- typechecked-only interface files, there's no way for a reference to occur+-- besides from the defining 'ClsInst' or closed type family).  Thus,+-- it doesn't really matter what names we give the DFun/CoAxiom, as long+-- as it's consistent between the declaration site and the use site.+--+-- We have to make sure that these bogus names don't get propagated,+-- but it is fine: see Note [Signature merging DFuns] for the fixups+-- to the names we do before writing out the merged interface.+-- (It's even easier for instantiation, since the DFuns all get+-- dropped entirely; the instances are reexported implicitly.)+--+-- Unfortunately, this strategy is not enough in the presence of promotion+-- (see bug #13149), where modules which import the signature may make+-- reference to their coercions.  It's not altogether clear how to+-- fix this case, but it is definitely a bug!++-- PILES AND PILES OF BOILERPLATE++-- | Rename an 'IfaceClsInst', with special handling for an associated+-- dictionary function.+rnIfaceClsInst :: Rename IfaceClsInst+rnIfaceClsInst cls_inst = do+    n <- rnIfaceGlobal (ifInstCls cls_inst)+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)++    dfun <- rnIfaceNeverExported (ifDFun cls_inst)+    return cls_inst { ifInstCls = n+                    , ifInstTys = tys+                    , ifDFun = dfun+                    }++rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)+rnMaybeIfaceTyCon Nothing = return Nothing+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc++rnIfaceFamInst :: Rename IfaceFamInst+rnIfaceFamInst d = do+    fam <- rnIfaceGlobal (ifFamInstFam d)+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }++rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl++rnIfaceDecl :: Rename IfaceDecl+rnIfaceDecl d@IfaceId{} = do+            name <- case ifIdDetails d of+                      IfDFunId -> rnIfaceNeverExported (ifName d)+                      _ | isDefaultMethodOcc (occName (ifName d))+                        -> rnIfaceNeverExported (ifName d)+                      -- Typeable bindings. See Note [Grand plan for Typeable].+                      _ | isTypeableBindOcc (occName (ifName d))+                        -> rnIfaceNeverExported (ifName d)+                        | otherwise -> rnIfaceGlobal (ifName d)+            ty <- rnIfaceType (ifType d)+            details <- rnIfaceIdDetails (ifIdDetails d)+            info <- rnIfaceIdInfo (ifIdInfo d)+            return d { ifName = name+                     , ifType = ty+                     , ifIdDetails = details+                     , ifIdInfo = info+                     }+rnIfaceDecl d@IfaceData{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            ctxt <- mapM rnIfaceType (ifCtxt d)+            cons <- rnIfaceConDecls (ifCons d)+            res_kind <- rnIfaceType (ifResKind d)+            parent <- rnIfaceTyConParent (ifParent d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifCtxt = ctxt+                     , ifCons = cons+                     , ifResKind = res_kind+                     , ifParent = parent+                     }+rnIfaceDecl d@IfaceSynonym{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            syn_kind <- rnIfaceType (ifResKind d)+            syn_rhs <- rnIfaceType (ifSynRhs d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifResKind = syn_kind+                     , ifSynRhs = syn_rhs+                     }+rnIfaceDecl d@IfaceFamily{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            fam_kind <- rnIfaceType (ifResKind d)+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifResKind = fam_kind+                     , ifFamFlav = fam_flav+                     }+rnIfaceDecl d@IfaceClass{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            body <- rnIfaceClassBody (ifBody d)+            return d { ifName    = name+                     , ifBinders = binders+                     , ifBody    = body+                     }+rnIfaceDecl d@IfaceAxiom{} = do+            name <- rnIfaceNeverExported (ifName d)+            tycon <- rnIfaceTyCon (ifTyCon d)+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)+            return d { ifName = name+                     , ifTyCon = tycon+                     , ifAxBranches = ax_branches+                     }+rnIfaceDecl d@IfacePatSyn{} =  do+            name <- rnIfaceGlobal (ifName d)+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b+            pat_matcher <- rnPat (ifPatMatcher d)+            pat_builder <- T.traverse rnPat (ifPatBuilder d)+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)+            pat_args <- mapM rnIfaceType (ifPatArgs d)+            pat_ty <- rnIfaceType (ifPatTy d)+            return d { ifName = name+                     , ifPatMatcher = pat_matcher+                     , ifPatBuilder = pat_builder+                     , ifPatUnivBndrs = pat_univ_bndrs+                     , ifPatExBndrs = pat_ex_bndrs+                     , ifPatProvCtxt = pat_prov_ctxt+                     , ifPatReqCtxt = pat_req_ctxt+                     , ifPatArgs = pat_args+                     , ifPatTy = pat_ty+                     }++rnIfaceClassBody :: Rename IfaceClassBody+rnIfaceClassBody IfAbstractClass = return IfAbstractClass+rnIfaceClassBody d@IfConcreteClass{} = do+    ctxt <- mapM rnIfaceType (ifClassCtxt d)+    ats <- mapM rnIfaceAT (ifATs d)+    sigs <- mapM rnIfaceClassOp (ifSigs d)+    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }++rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n+                                                <*> mapM rnIfaceAxBranch axs)+rnIfaceFamTyConFlav flav = pure flav++rnIfaceAT :: Rename IfaceAT+rnIfaceAT (IfaceAT decl mb_ty)+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty++rnIfaceTyConParent :: Rename IfaceTyConParent+rnIfaceTyConParent (IfDataInstance n tc args)+    = IfDataInstance <$> rnIfaceGlobal n+                     <*> rnIfaceTyCon tc+                     <*> rnIfaceAppArgs args+rnIfaceTyConParent IfNoParent = pure IfNoParent++rnIfaceConDecls :: Rename IfaceConDecls+rnIfaceConDecls (IfDataTyCon ds)+    = IfDataTyCon <$> mapM rnIfaceConDecl ds+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d+rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon++rnIfaceConDecl :: Rename IfaceConDecl+rnIfaceConDecl d = do+    con_name <- rnIfaceGlobal (ifConName d)+    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)+    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)+    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)+    con_fields <- mapM rnFieldLabel (ifConFields d)+    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co+        rnIfaceBang bang = pure bang+    con_stricts <- mapM rnIfaceBang (ifConStricts d)+    return d { ifConName = con_name+             , ifConExTCvs = con_ex_tvs+             , ifConUserTvBinders = con_user_tvbs+             , ifConEqSpec = con_eq_spec+             , ifConCtxt = con_ctxt+             , ifConArgTys = con_arg_tys+             , ifConFields = con_fields+             , ifConStricts = con_stricts+             }++rnIfaceClassOp :: Rename IfaceClassOp+rnIfaceClassOp (IfaceClassOp n ty dm) =+    IfaceClassOp <$> rnIfaceGlobal n+                 <*> rnIfaceType ty+                 <*> rnMaybeDefMethSpec dm++rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty+rnMaybeDefMethSpec mb = return mb++rnIfaceAxBranch :: Rename IfaceAxBranch+rnIfaceAxBranch d = do+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)+    lhs <- rnIfaceAppArgs (ifaxbLHS d)+    rhs <- rnIfaceType (ifaxbRHS d)+    return d { ifaxbTyVars = ty_vars+             , ifaxbLHS = lhs+             , ifaxbRHS = rhs }++rnIfaceIdInfo :: Rename IfaceIdInfo+rnIfaceIdInfo NoInfo = pure NoInfo+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is++rnIfaceInfoItem :: Rename IfaceInfoItem+rnIfaceInfoItem (HsUnfold lb if_unf)+    = HsUnfold lb <$> rnIfaceUnfolding if_unf+rnIfaceInfoItem i+    = pure i++rnIfaceUnfolding :: Rename IfaceUnfolding+rnIfaceUnfolding (IfCoreUnfold stable if_expr)+    = IfCoreUnfold stable <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfCompulsory if_expr)+    = IfCompulsory <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)+    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfDFunUnfold bs ops)+    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops++rnIfaceExpr :: Rename IfaceExpr+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args+rnIfaceExpr (IfaceLam lam_bndr expr)+    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr+rnIfaceExpr (IfaceApp fun arg)+    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg+rnIfaceExpr (IfaceCase scrut case_bndr alts)+    = IfaceCase <$> rnIfaceExpr scrut+                <*> pure case_bndr+                <*> mapM rnIfaceAlt alts+rnIfaceExpr (IfaceECase scrut ty)+    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)+    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)+               <*> rnIfaceExpr body+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)+    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->+                                        (,) <$> rnIfaceLetBndr bndr+                                            <*> rnIfaceExpr rhs) pairs)+               <*> rnIfaceExpr body+rnIfaceExpr (IfaceCast expr co)+    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr++rnIfaceBndrs :: Rename [IfaceBndr]+rnIfaceBndrs = mapM rnIfaceBndr++rnIfaceBndr :: Rename IfaceBndr+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr++rnIfaceTvBndr :: Rename IfaceTvBndr+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind++rnIfaceTyConBinder :: Rename IfaceTyConBinder+rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis++rnIfaceAlt :: Rename IfaceAlt+rnIfaceAlt (conalt, names, rhs)+     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs++rnIfaceConAlt :: Rename IfaceConAlt+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ+rnIfaceConAlt alt = pure alt++rnIfaceLetBndr :: Rename IfaceLetBndr+rnIfaceLetBndr (IfLetBndr fs ty info jpi)+    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi++rnIfaceLamBndr :: Rename IfaceLamBndr+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot++rnIfaceMCo :: Rename IfaceMCoercion+rnIfaceMCo IfaceMRefl    = pure IfaceMRefl+rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co++rnIfaceCo :: Rename IfaceCoercion+rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty+rnIfaceCo (IfaceGReflCo role ty mco)+  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco+rnIfaceCo (IfaceFunCo role co1 co2)+    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceTyConAppCo role tc cos)+    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos+rnIfaceCo (IfaceAppCo co1 co2)+    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceForAllCo bndr co1 co2)+    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl+rnIfaceCo (IfaceAxiomInstCo n i cs)+    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs+rnIfaceCo (IfaceUnivCo s r t1 t2)+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceCo (IfaceSymCo c)+    = IfaceSymCo <$> rnIfaceCo c+rnIfaceCo (IfaceTransCo c1 c2)+    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceInstCo c1 c2)+    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c+rnIfaceCo (IfaceAxiomRuleCo ax cos)+    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c++rnIfaceTyCon :: Rename IfaceTyCon+rnIfaceTyCon (IfaceTyCon n info)+    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info++rnIfaceExprs :: Rename [IfaceExpr]+rnIfaceExprs = mapM rnIfaceExpr++rnIfaceIdDetails :: Rename IfaceIdDetails+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b+rnIfaceIdDetails details = pure details++rnIfaceType :: Rename IfaceType+rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)+rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)+rnIfaceType (IfaceAppTy t1 t2)+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2+rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)+rnIfaceType (IfaceFunTy af t1 t2)+    = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceTupleTy s i tks)+    = IfaceTupleTy s i <$> rnIfaceAppArgs tks+rnIfaceType (IfaceTyConApp tc tks)+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks+rnIfaceType (IfaceForAllTy tv t)+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t+rnIfaceType (IfaceCoercionTy co)+    = IfaceCoercionTy <$> rnIfaceCo co+rnIfaceType (IfaceCastTy ty co)+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co++rnIfaceForAllBndr :: Rename IfaceForAllBndr+rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis++rnIfaceAppArgs :: Rename IfaceAppArgs+rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a+                                        <*> rnIfaceAppArgs ts+rnIfaceAppArgs IA_Nil = pure IA_Nil
+ compiler/GHC/Iface/Tidy.hs view
@@ -0,0 +1,1489 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{Tidying up Core}+-}++{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Iface.Tidy (+       mkBootModDetailsTc, tidyProgram+   ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnTypes+import DynFlags+import CoreSyn+import CoreUnfold+import CoreFVs+import CoreTidy+import CoreMonad+import GHC.CoreToStg.Prep+import CoreUtils        (rhsIsStatic)+import CoreStats        (coreBindsStats, CoreStats(..))+import CoreSeq          (seqBinds)+import CoreLint+import Literal+import Rules+import PatSyn+import ConLike+import CoreArity        ( exprArity, exprBotStrictness_maybe )+import StaticPtrTable+import VarEnv+import VarSet+import Var+import Id+import MkId             ( mkDictSelRhs )+import IdInfo+import InstEnv+import Type             ( tidyTopType )+import Demand           ( appIsBottom, isTopSig, isBottomingSig )+import BasicTypes+import Name hiding (varName)+import NameSet+import NameCache+import Avail+import GHC.Iface.Env+import TcEnv+import TcRnMonad+import DataCon+import TyCon+import Class+import Module+import Packages( isDllName )+import HscTypes+import Maybes+import UniqSupply+import Outputable+import Util( filterOut )+import qualified ErrUtils as Err++import Control.Monad+import Data.Function+import Data.List        ( sortBy, mapAccumL )+import Data.IORef       ( atomicModifyIORef' )++{-+Constructing the TypeEnv, Instances, Rules from which the+ModIface is constructed, and which goes on to subsequent modules in+--make mode.++Most of the interface file is obtained simply by serialising the+TypeEnv.  One important consequence is that if the *interface file*+has pragma info if and only if the final TypeEnv does. This is not so+important for *this* module, but it's essential for ghc --make:+subsequent compilations must not see (e.g.) the arity if the interface+file does not contain arity If they do, they'll exploit the arity;+then the arity might change, but the iface file doesn't change =>+recompilation does not happen => disaster.++For data types, the final TypeEnv will have a TyThing for the TyCon,+plus one for each DataCon; the interface file will contain just one+data type declaration, but it is de-serialised back into a collection+of TyThings.++************************************************************************+*                                                                      *+                Plan A: simpleTidyPgm+*                                                                      *+************************************************************************+++Plan A: mkBootModDetails: omit pragmas, make interfaces small+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Ignore the bindings++* Drop all WiredIn things from the TypeEnv+        (we never want them in interface files)++* Retain all TyCons and Classes in the TypeEnv, to avoid+        having to find which ones are mentioned in the+        types of exported Ids++* Trim off the constructors of non-exported TyCons, both+        from the TyCon and from the TypeEnv++* Drop non-exported Ids from the TypeEnv++* Tidy the types of the DFunIds of Instances,+  make them into GlobalIds, (they already have External Names)+  and add them to the TypeEnv++* Tidy the types of the (exported) Ids in the TypeEnv,+  make them into GlobalIds (they already have External Names)++* Drop rules altogether++* Tidy the bindings, to ensure that the Caf and Arity+  information is correct for each top-level binder; the+  code generator needs it. And to ensure that local names have+  distinct OccNames in case of object-file splitting++* If this an hsig file, drop the instances altogether too (they'll+  get pulled in by the implicit module import.+-}++-- This is Plan A: make a small type env when typechecking only,+-- or when compiling a hs-boot file, or simply when not using -O+--+-- We don't look at the bindings at all -- there aren't any+-- for hs-boot files++mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails+mkBootModDetailsTc hsc_env+        TcGblEnv{ tcg_exports          = exports,+                  tcg_type_env         = type_env, -- just for the Ids+                  tcg_tcs              = tcs,+                  tcg_patsyns          = pat_syns,+                  tcg_insts            = insts,+                  tcg_fam_insts        = fam_insts,+                  tcg_complete_matches = complete_sigs,+                  tcg_mod              = this_mod+                }+  = -- This timing isn't terribly useful since the result isn't forced, but+    -- the message is useful to locating oneself in the compilation process.+    Err.withTiming dflags+                   (text "CoreTidy"<+>brackets (ppr this_mod))+                   (const ()) $+    return (ModDetails { md_types         = type_env'+                       , md_insts         = insts'+                       , md_fam_insts     = fam_insts+                       , md_rules         = []+                       , md_anns          = []+                       , md_exports       = exports+                       , md_complete_sigs = complete_sigs+                       })+  where+    dflags = hsc_dflags hsc_env++    -- Find the LocalIds in the type env that are exported+    -- Make them into GlobalIds, and tidy their types+    --+    -- It's very important to remove the non-exported ones+    -- because we don't tidy the OccNames, and if we don't remove+    -- the non-exported ones we'll get many things with the+    -- same name in the interface file, giving chaos.+    --+    -- Do make sure that we keep Ids that are already Global.+    -- When typechecking an .hs-boot file, the Ids come through as+    -- GlobalIds.+    final_ids = [ globaliseAndTidyBootId id+                | id <- typeEnvIds type_env+                , keep_it id ]++    final_tcs  = filterOut isWiredIn tcs+                 -- See Note [Drop wired-in things]+    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts+    insts'     = mkFinalClsInsts type_env1 insts+    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns+    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1++    -- Default methods have their export flag set (isExportedId),+    -- but everything else doesn't (yet), because this is+    -- pre-desugaring, so we must test against the exports too.+    keep_it id | isWiredInName id_name           = False+                 -- See Note [Drop wired-in things]+               | isExportedId id                 = True+               | id_name `elemNameSet` exp_names = True+               | otherwise                       = False+               where+                 id_name = idName id++    exp_names = availsToNameSet exports++lookupFinalId :: TypeEnv -> Id -> Id+lookupFinalId type_env id+  = case lookupTypeEnv type_env (idName id) of+      Just (AnId id') -> id'+      _ -> pprPanic "lookup_final_id" (ppr id)++mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]+mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))++mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]+mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))++extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv+extendTypeEnvWithPatSyns tidy_patsyns type_env+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]++globaliseAndTidyBootId :: Id -> Id+-- For a LocalId with an External Name,+-- makes it into a GlobalId+--     * unchanged Name (might be Internal or External)+--     * unchanged details+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)+--     * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface)+globaliseAndTidyBootId id+  = globaliseId id `setIdType`      tidyTopType (idType id)+                   `setIdUnfolding` BootUnfolding++{-+************************************************************************+*                                                                      *+        Plan B: tidy bindings, make TypeEnv full of IdInfo+*                                                                      *+************************************************************************++Plan B: include pragmas, make interfaces+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Step 1: Figure out which Ids are externally visible+          See Note [Choosing external Ids]++* Step 2: Gather the externally visible rules, separately from+          the top-level bindings.+          See Note [Finding external rules]++* Step 3: Tidy the bindings, externalising appropriate Ids+          See Note [Tidy the top-level bindings]++* Drop all Ids from the TypeEnv, and add all the External Ids from+  the bindings.  (This adds their IdInfo to the TypeEnv; and adds+  floated-out Ids that weren't even in the TypeEnv before.)++Note [Choosing external Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also the section "Interface stability" in the+recompilation-avoidance commentary:+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance++First we figure out which Ids are "external" Ids.  An+"external" Id is one that is visible from outside the compilation+unit.  These are+  a) the user exported ones+  b) the ones bound to static forms+  c) ones mentioned in the unfoldings, workers, or+     rules of externally-visible ones++While figuring out which Ids are external, we pick a "tidy" OccName+for each one.  That is, we make its OccName distinct from the other+external OccNames in this module, so that in interface files and+object code we can refer to it unambiguously by its OccName.  The+OccName for each binder is prefixed by the name of the exported Id+that references it; e.g. if "f" references "x" in its unfolding, then+"x" is renamed to "f_x".  This helps distinguish the different "x"s+from each other, and means that if "f" is later removed, things that+depend on the other "x"s will not need to be recompiled.  Of course,+if there are multiple "f_x"s, then we have to disambiguate somehow; we+use "f_x0", "f_x1" etc.++As far as possible we should assign names in a deterministic fashion.+Each time this module is compiled with the same options, we should end+up with the same set of external names with the same types.  That is,+the ABI hash in the interface should not change.  This turns out to be+quite tricky, since the order of the bindings going into the tidy+phase is already non-deterministic, as it is based on the ordering of+Uniques, which are assigned unpredictably.++To name things in a stable way, we do a depth-first-search of the+bindings, starting from the exports sorted by name.  This way, as long+as the bindings themselves are deterministic (they sometimes aren't!),+the order in which they are presented to the tidying phase does not+affect the names we assign.++Note [Tidy the top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Next we traverse the bindings top to bottom.  For each *top-level*+binder++ 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,+    reflecting the fact that from now on we regard it as a global,+    not local, Id++ 2. Give it a system-wide Unique.+    [Even non-exported things need system-wide Uniques because the+    byte-code generator builds a single Name->BCO symbol table.]++    We use the NameCache kept in the HscEnv as the+    source of such system-wide uniques.++    For external Ids, use the original-name cache in the NameCache+    to ensure that the unique assigned is the same as the Id had+    in any previous compilation run.++ 3. Rename top-level Ids according to the names we chose in step 1.+    If it's an external Id, make it have a External Name, otherwise+    make it have an Internal Name.  This is used by the code generator+    to decide whether to make the label externally visible++ 4. Give it its UTTERLY FINAL IdInfo; in ptic,+        * its unfolding, if it should have one++        * its arity, computed from the number of visible lambdas++        * its CAF info, computed from what is free in its RHS+++Finally, substitute these new top-level binders consistently+throughout, including in unfoldings.  We also tidy binders in+RHSs, so that they print nicely in interfaces.+-}++tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)+tidyProgram hsc_env  (ModGuts { mg_module    = mod+                              , mg_exports   = exports+                              , mg_rdr_env   = rdr_env+                              , mg_tcs       = tcs+                              , mg_insts     = cls_insts+                              , mg_fam_insts = fam_insts+                              , mg_binds     = binds+                              , mg_patsyns   = patsyns+                              , mg_rules     = imp_rules+                              , mg_anns      = anns+                              , mg_complete_sigs = complete_sigs+                              , mg_deps      = deps+                              , mg_foreign   = foreign_stubs+                              , mg_foreign_files = foreign_files+                              , mg_hpc_info  = hpc_info+                              , mg_modBreaks = modBreaks+                              })++  = Err.withTiming dflags+                   (text "CoreTidy"<+>brackets (ppr mod))+                   (const ()) $+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags+              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags+              ; print_unqual = mkPrintUnqualified dflags rdr_env+              ; implicit_binds = concatMap getImplicitBinds tcs+              }++        ; (unfold_env, tidy_occ_env)+              <- chooseExternalIds hsc_env mod omit_prags expose_all+                                   binds implicit_binds imp_rules+        ; let { (trimmed_binds, trimmed_rules)+                    = findExternalRules omit_prags binds imp_rules unfold_env }++        ; (tidy_env, tidy_binds)+                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds++          -- See Note [Grand plan for static forms] in StaticPtrTable.+        ; (spt_entries, tidy_binds') <-+             sptCreateStaticBinds hsc_env mod tidy_binds+        ; let { spt_init_code = sptModuleInitCode mod spt_entries+              ; add_spt_init_code =+                  case hscTarget dflags of+                    -- If we are compiling for the interpreter we will insert+                    -- any necessary SPT entries dynamically+                    HscInterpreted -> id+                    -- otherwise add a C stub to do so+                    _              -> (`appendStubC` spt_init_code)++              -- The completed type environment is gotten from+              --      a) the types and classes defined here (plus implicit things)+              --      b) adding Ids with correct IdInfo, including unfoldings,+              --              gotten from the bindings+              -- From (b) we keep only those Ids with External names;+              --          the CoreTidy pass makes sure these are all and only+              --          the externally-accessible ones+              -- This truncates the type environment to include only the+              -- exported Ids and things needed from them, which saves space+              --+              -- See Note [Don't attempt to trim data types]+              ; final_ids  = [ if omit_prags then trimId id else id+                             | id <- bindersOfBinds tidy_binds+                             , isExternalName (idName id)+                             , not (isWiredIn id)+                             ]   -- See Note [Drop wired-in things]++              ; final_tcs      = filterOut isWiredIn tcs+                                 -- See Note [Drop wired-in things]+              ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts+              ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts+              ; tidy_patsyns   = mkFinalPatSyns  type_env patsyns+              ; tidy_type_env  = extendTypeEnvWithPatSyns tidy_patsyns type_env+              ; tidy_rules     = tidyRules tidy_env trimmed_rules++              ; -- See Note [Injecting implicit bindings]+                all_tidy_binds = implicit_binds ++ tidy_binds'++              -- Get the TyCons to generate code for.  Careful!  We must use+              -- the untidied TyCons here, because we need+              --  (a) implicit TyCons arising from types and classes defined+              --      in this module+              --  (b) wired-in TyCons, which are normally removed from the+              --      TypeEnv we put in the ModDetails+              --  (c) Constructors even if they are not exported (the+              --      tidied TypeEnv has trimmed these away)+              ; alg_tycons = filter isAlgTyCon tcs+              }++        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules++          -- If the endPass didn't print the rules, but ddump-rules is+          -- on, print now+        ; unless (dopt Opt_D_dump_simpl dflags) $+            Err.dumpIfSet_dyn dflags Opt_D_dump_rules+              (showSDoc dflags (ppr CoreTidy <+> text "rules"))+              Err.FormatText+              (pprRulesForUser dflags tidy_rules)++          -- Print one-line size info+        ; let cs = coreBindsStats tidy_binds+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"+            Err.FormatText+            (text "Tidy size (terms,types,coercions)"+             <+> ppr (moduleName mod) <> colon+             <+> int (cs_tm cs)+             <+> int (cs_ty cs)+             <+> int (cs_co cs) )++        ; return (CgGuts { cg_module   = mod,+                           cg_tycons   = alg_tycons,+                           cg_binds    = all_tidy_binds,+                           cg_foreign  = add_spt_init_code foreign_stubs,+                           cg_foreign_files = foreign_files,+                           cg_dep_pkgs = map fst $ dep_pkgs deps,+                           cg_hpc_info = hpc_info,+                           cg_modBreaks = modBreaks,+                           cg_spt_entries = spt_entries },++                   ModDetails { md_types     = tidy_type_env,+                                md_rules     = tidy_rules,+                                md_insts     = tidy_cls_insts,+                                md_fam_insts = fam_insts,+                                md_exports   = exports,+                                md_anns      = anns,      -- are already tidy+                                md_complete_sigs = complete_sigs+                              })+        }+  where+    dflags = hsc_dflags hsc_env++--------------------------+trimId :: Id -> Id+trimId id+  | not (isImplicitId id)+  = id `setIdInfo` vanillaIdInfo+  | otherwise+  = id++{- Note [Drop wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never put wired-in TyCons or Ids in an interface file.+They are wired-in, so the compiler knows about them already.++Note [Don't attempt to trim data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some time GHC tried to avoid exporting the data constructors+of a data type if it wasn't strictly necessary to do so; see #835.+But "strictly necessary" accumulated a longer and longer list+of exceptions, and finally I gave up the battle:++    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11+    Author: Simon Peyton Jones <simonpj@microsoft.com>+    Date:   Thu Dec 6 16:03:16 2012 +0000++    Stop attempting to "trim" data types in interface files++    Without -O, we previously tried to make interface files smaller+    by not including the data constructors of data types.  But+    there are a lot of exceptions, notably when Template Haskell is+    involved or, more recently, DataKinds.++    However #7445 shows that even without TemplateHaskell, using+    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ+    is enough to require us to expose the data constructors.++    So I've given up on this "optimisation" -- it's probably not+    important anyway.  Now I'm simply not attempting to trim off+    the data constructors.  The gain in simplicity is worth the+    modest cost in interface file growth, which is limited to the+    bits reqd to describe those data constructors.++************************************************************************+*                                                                      *+        Implicit bindings+*                                                                      *+************************************************************************++Note [Injecting implicit bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We inject the implicit bindings right at the end, in CoreTidy.+Some of these bindings, notably record selectors, are not+constructed in an optimised form.  E.g. record selector for+        data T = MkT { x :: {-# UNPACK #-} !Int }+Then the unfolding looks like+        x = \t. case t of MkT x1 -> let x = I# x1 in x+This generates bad code unless it's first simplified a bit.  That is+why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of+optimisation first.  (Only matters when the selector is used curried;+eg map x ys.)  See #2070.++[Oct 09: in fact, record selectors are no longer implicit Ids at all,+because we really do want to optimise them properly. They are treated+much like any other Id.  But doing "light" optimisation on an implicit+Id still makes sense.]++At one time I tried injecting the implicit bindings *early*, at the+beginning of SimplCore.  But that gave rise to real difficulty,+because GlobalIds are supposed to have *fixed* IdInfo, but the+simplifier and other core-to-core passes mess with IdInfo all the+time.  The straw that broke the camels back was when a class selector+got the wrong arity -- ie the simplifier gave it arity 2, whereas+importing modules were expecting it to have arity 1 (#2844).+It's much safer just to inject them right at the end, after tidying.++Oh: two other reasons for injecting them late:++  - If implicit Ids are already in the bindings when we start tidying,+    we'd have to be careful not to treat them as external Ids (in+    the sense of chooseExternalIds); else the Ids mentioned in *their*+    RHSs will be treated as external and you get an interface file+    saying      a18 = <blah>+    but nothing referring to a18 (because the implicit Id is the+    one that does, and implicit Ids don't appear in interface files).++  - More seriously, the tidied type-envt will include the implicit+    Id replete with a18 in its unfolding; but we won't take account+    of a18 when computing a fingerprint for the class; result chaos.++There is one sort of implicit binding that is injected still later,+namely those for data constructor workers. Reason (I think): it's+really just a code generation trick.... binding itself makes no sense.+See Note [Data constructor workers] in CorePrep.+-}++getImplicitBinds :: TyCon -> [CoreBind]+getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc+  where+    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)++getTyConImplicitBinds :: TyCon -> [CoreBind]+getTyConImplicitBinds tc+  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId+  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))++getClassImplicitBinds :: Class -> [CoreBind]+getClassImplicitBinds cls+  = [ NonRec op (mkDictSelRhs cls val_index)+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]++get_defn :: Id -> CoreBind+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))++{-+************************************************************************+*                                                                      *+\subsection{Step 1: finding externals}+*                                                                      *+************************************************************************++See Note [Choosing external Ids].+-}++type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})+  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)+  -- The Unique is unchanged.  If the new Name is external, it will be+  -- visible in the interface file.+  --+  -- Bool => expose unfolding or not.++chooseExternalIds :: HscEnv+                  -> Module+                  -> Bool -> Bool+                  -> [CoreBind]+                  -> [CoreBind]+                  -> [CoreRule]+                  -> IO (UnfoldEnv, TidyOccEnv)+                  -- Step 1 from the notes above++chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules+  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env+       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders+       ; tidy_internal internal_ids unfold_env1 occ_env1 }+ where+  nc_var = hsc_NC hsc_env++  -- init_ext_ids is the initial list of Ids that should be+  -- externalised.  It serves as the starting point for finding a+  -- deterministic, tidy, renaming for all external Ids in this+  -- module.+  --+  -- It is sorted, so that it has a deterministic order (i.e. it's the+  -- same list every time this module is compiled), in contrast to the+  -- bindings, which are ordered non-deterministically.+  init_work_list = zip init_ext_ids init_ext_ids+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders++  -- An Id should be external if either (a) it is exported,+  -- (b) it appears in the RHS of a local rule for an imported Id, or+  -- See Note [Which rules to expose]+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars++  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules++  binders          = map fst $ flattenBinds binds+  implicit_binders = bindersOfBinds implicit_binds+  binder_set       = mkVarSet binders++  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,+                                let name = idName bndr,+                                isExternalName name ]+                -- In computing our "avoids" list, we must include+                --      all implicit Ids+                --      all things with global names (assigned once and for+                --                                      all by the renamer)+                -- since their names are "taken".+                -- The type environment is a convenient source of such things.+                -- In particular, the set of binders doesn't include+                -- implicit Ids at this stage.++        -- We also make sure to avoid any exported binders.  Consider+        --      f{-u1-} = 1     -- Local decl+        --      ...+        --      f{-u2-} = 2     -- Exported decl+        --+        -- The second exported decl must 'get' the name 'f', so we+        -- have to put 'f' in the avoids list before we get to the first+        -- decl.  tidyTopId then does a no-op on exported binders.+  init_occ_env = initTidyOccEnv avoids+++  search :: [(Id,Id)]    -- The work-list: (external id, referring id)+                         -- Make a tidy, external Name for the external id,+                         --   add it to the UnfoldEnv, and do the same for the+                         --   transitive closure of Ids it refers to+                         -- The referring id is used to generate a tidy+                         ---  name for the external id+         -> UnfoldEnv    -- id -> (new Name, show_unfold)+         -> TidyOccEnv   -- occ env for choosing new Names+         -> IO (UnfoldEnv, TidyOccEnv)++  search [] unfold_env occ_env = return (unfold_env, occ_env)++  search ((idocc,referrer) : rest) unfold_env occ_env+    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env+    | otherwise = do+      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc+      let+          (new_ids, show_unfold)+                | omit_prags = ([], False)+                | otherwise  = addExternal expose_all refined_id++                -- 'idocc' is an *occurrence*, but we need to see the+                -- unfolding in the *definition*; so look up in binder_set+          refined_id = case lookupVarSet binder_set idocc of+                         Just id -> id+                         Nothing -> WARN( True, ppr idocc ) idocc++          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)+          referrer' | isExportedId refined_id = refined_id+                    | otherwise               = referrer+      --+      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'++  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv+                -> IO (UnfoldEnv, TidyOccEnv)+  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)+  tidy_internal (id:ids) unfold_env occ_env = do+      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id+      let unfold_env' = extendVarEnv unfold_env id (name',False)+      tidy_internal ids unfold_env' occ_env'++addExternal :: Bool -> Id -> ([Id], Bool)+addExternal expose_all id = (new_needed_ids, show_unfold)+  where+    new_needed_ids = bndrFvsInOrder show_unfold id+    idinfo         = idInfo id+    show_unfold    = show_unfolding (unfoldingInfo idinfo)+    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))+    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)+    bottoming_fn   = isBottomingSig (strictnessInfo idinfo)++        -- Stuff to do with the Id's unfolding+        -- We leave the unfolding there even if there is a worker+        -- In GHCi the unfolding is used by importers++    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })+       =  expose_all         -- 'expose_all' says to expose all+                             -- unfoldings willy-nilly++       || isStableSource src     -- Always expose things whose+                                 -- source is an inline rule++       || not (bottoming_fn      -- No need to inline bottom functions+           || never_active       -- Or ones that say not to+           || loop_breaker       -- Or that are loop breakers+           || neverUnfoldGuidance guidance)+    show_unfolding (DFunUnfolding {}) = True+    show_unfolding _                  = False++{-+************************************************************************+*                                                                      *+               Deterministic free variables+*                                                                      *+************************************************************************++We want a deterministic free-variable list.  exprFreeVars gives us+a VarSet, which is in a non-deterministic order when converted to a+list.  Hence, here we define a free-variable finder that returns+the free variables in the order that they are encountered.++See Note [Choosing external Ids]+-}++bndrFvsInOrder :: Bool -> Id -> [Id]+bndrFvsInOrder show_unfold id+  = run (dffvLetBndr show_unfold id)++run :: DFFV () -> [Id]+run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of+                 ((_,ids),_) -> ids++newtype DFFV a+  = DFFV (VarSet              -- Envt: non-top-level things that are in scope+                              -- we don't want to record these as free vars+      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far+      -> ((VarSet,[Var]),a))  -- Output state+    deriving (Functor)++instance Applicative DFFV where+    pure a = DFFV $ \_ st -> (st, a)+    (<*>) = ap++instance Monad DFFV where+  (DFFV m) >>= k = DFFV $ \env st ->+    case m env st of+       (st',a) -> case k a of+                     DFFV f -> f env st'++extendScope :: Var -> DFFV a -> DFFV a+extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)++extendScopeList :: [Var] -> DFFV a -> DFFV a+extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)++insert :: Var -> DFFV ()+insert v = DFFV $ \ env (set, ids) ->+           let keep_me = isLocalId v &&+                         not (v `elemVarSet` env) &&+                           not (v `elemVarSet` set)+           in if keep_me+              then ((extendVarSet set v, v:ids), ())+              else ((set,                ids),   ())+++dffvExpr :: CoreExpr -> DFFV ()+dffvExpr (Var v)              = insert v+dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2+dffvExpr (Lam v e)            = extendScope v (dffvExpr e)+dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e+dffvExpr (Tick _other e)    = dffvExpr e+dffvExpr (Cast e _)           = dffvExpr e+dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)+dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $+                                (mapM_ dffvBind prs >> dffvExpr e)+dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)+dffvExpr _other               = return ()++dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()+dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)++dffvBind :: (Id, CoreExpr) -> DFFV ()+dffvBind(x,r)+  | not (isId x) = dffvExpr r+  | otherwise    = dffvLetBndr False x >> dffvExpr r+                -- Pass False because we are doing the RHS right here+                -- If you say True you'll get *exponential* behaviour!++dffvLetBndr :: Bool -> Id -> DFFV ()+-- Gather the free vars of the RULES and unfolding of a binder+-- We always get the free vars of a *stable* unfolding, but+-- for a *vanilla* one (InlineRhs), the flag controls what happens:+--   True <=> get fvs of even a *vanilla* unfolding+--   False <=> ignore an InlineRhs+-- For nested bindings (call from dffvBind) we always say "False" because+--       we are taking the fvs of the RHS anyway+-- For top-level bindings (call from addExternal, via bndrFvsInOrder)+--       we say "True" if we are exposing that unfolding+dffvLetBndr vanilla_unfold id+  = do { go_unf (unfoldingInfo idinfo)+       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }+  where+    idinfo = idInfo id++    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })+       = case src of+           InlineRhs | vanilla_unfold -> dffvExpr rhs+                     | otherwise      -> return ()+           _                          -> dffvExpr rhs++    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })+             = extendScopeList bndrs $ mapM_ dffvExpr args+    go_unf _ = return ()++    go_rule (BuiltinRule {}) = return ()+    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })+      = extendScopeList bndrs (dffvExpr rhs)++{-+************************************************************************+*                                                                      *+               findExternalRules+*                                                                      *+************************************************************************++Note [Finding external rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The complete rules are gotten by combining+   a) local rules for imported Ids+   b) rules embedded in the top-level Ids++There are two complications:+  * Note [Which rules to expose]+  * Note [Trimming auto-rules]++Note [Which rules to expose]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function 'expose_rule' filters out rules that mention, on the LHS,+Ids that aren't externally visible; these rules can't fire in a client+module.++The externally-visible binders are computed (by chooseExternalIds)+assuming that all orphan rules are externalised (see init_ext_ids in+function 'search'). So in fact it's a bit conservative and we may+export more than we need.  (It's a sort of mutual recursion.)++Note [Trimming auto-rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Second, with auto-specialisation we may specialise local or imported+dfuns or INLINE functions, and then later inline them.  That may leave+behind something like+   RULE "foo" forall d. f @ Int d = f_spec+where f is either local or imported, and there is no remaining+reference to f_spec except from the RULE.++Now that RULE *might* be useful to an importing module, but that is+purely speculative, and meanwhile the code is taking up space and+codegen time.  I found that binary sizes jumped by 6-10% when I+started to specialise INLINE functions (again, Note [Inline+specialisations] in Specialise).++So it seems better to drop the binding for f_spec, and the rule+itself, if the auto-generated rule is the *only* reason that it is+being kept alive.++(The RULE still might have been useful in the past; that is, it was+the right thing to have generated it in the first place.  See Note+[Inline specialisations] in Specialise.  But now it has served its+purpose, and can be discarded.)++So findExternalRules does this:+  * Remove all bindings that are kept alive *only* by isAutoRule rules+      (this is done in trim_binds)+  * Remove all auto rules that mention bindings that have been removed+      (this is done by filtering by keep_rule)++NB: if a binding is kept alive for some *other* reason (e.g. f_spec is+called in the final code), we keep the rule too.++This stuff is the only reason for the ru_auto field in a Rule.+-}++findExternalRules :: Bool       -- Omit pragmas+                  -> [CoreBind]+                  -> [CoreRule] -- Local rules for imported fns+                  -> UnfoldEnv  -- Ids that are exported, so we need their rules+                  -> ([CoreBind], [CoreRule])+-- See Note [Finding external rules]+findExternalRules omit_prags binds imp_id_rules unfold_env+  = (trimmed_binds, filter keep_rule all_rules)+  where+    imp_rules         = filter expose_rule imp_id_rules+    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules++    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet+                           | otherwise       = ruleRhsFreeVars rule++    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds++    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs+        -- Remove rules that make no sense, because they mention a+        -- local binder (on LHS or RHS) that we have now discarded.+        -- (NB: ruleFreeVars only includes LocalIds)+        --+        -- LHS: we have already filtered out rules that mention internal Ids+        --     on LHS but that isn't enough because we might have by now+        --     discarded a binding with an external Id. (How?+        --     chooseExternalIds is a bit conservative.)+        --+        -- RHS: the auto rules that might mention a binder that has+        --      been discarded; see Note [Trimming auto-rules]++    expose_rule rule+        | omit_prags = False+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)+                -- Don't expose a rule whose LHS mentions a locally-defined+                -- Id that is completely internal (i.e. not visible to an+                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.+                -- See Note [Which rules to expose]++    is_external_id id = case lookupVarEnv unfold_env id of+                          Just (name, _) -> isExternalName name+                          Nothing        -> False++    trim_binds :: [CoreBind]+               -> ( [CoreBind]   -- Trimmed bindings+                  , VarSet       -- Binders of those bindings+                  , VarSet       -- Free vars of those bindings + rhs of user rules+                                 -- (we don't bother to delete the binders)+                  , [CoreRule])  -- All rules, imported + from the bindings+    -- This function removes unnecessary bindings, and gathers up rules from+    -- the bindings we keep.  See Note [Trimming auto-rules]+    trim_binds []  -- Base case, start with imp_user_rule_fvs+       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)++    trim_binds (bind:binds)+       | any needed bndrs    -- Keep binding+       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )+       | otherwise           -- Discard binding altogether+       = stuff+       where+         stuff@(binds', bndr_set, needed_fvs, rules)+                       = trim_binds binds+         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs++         bndrs         = bindersOf  bind+         rhss          = rhssOfBind bind+         bndr_set'     = bndr_set `extendVarSetList` bndrs++         needed_fvs'   = needed_fvs                                   `unionVarSet`+                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`+                              -- Ignore type variables in the type of bndrs+                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`+                         mapUnionVarSet user_rule_rhs_fvs local_rules+            -- In needed_fvs', we don't bother to delete binders from the fv set++         local_rules  = [ rule+                        | id <- bndrs+                        , is_external_id id   -- Only collect rules for external Ids+                        , rule <- idCoreRules id+                        , expose_rule rule ]  -- and ones that can fire in a client++{-+************************************************************************+*                                                                      *+               tidyTopName+*                                                                      *+************************************************************************++This is where we set names to local/global based on whether they really are+externally visible (see comment at the top of this module).  If the name+was previously local, we have to give it a unique occurrence name if+we intend to externalise it.+-}++tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv+            -> Id -> IO (TidyOccEnv, Name)+tidyTopName mod nc_var maybe_ref occ_env id+  | global && internal = return (occ_env, localiseName name)++  | global && external = return (occ_env, name)+        -- Global names are assumed to have been allocated by the renamer,+        -- so they already have the "right" unique+        -- And it's a system-wide unique too++  -- Now we get to the real reason that all this is in the IO Monad:+  -- we have to update the name cache in a nice atomic fashion++  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local+                            ; return (occ_env', new_local_name) }+        -- Even local, internal names must get a unique occurrence, because+        -- if we do -split-objs we externalise the name later, in the code generator+        --+        -- Similarly, we must make sure it has a system-wide Unique, because+        -- the byte-code generator builds a system-wide Name->BCO symbol table++  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external+                            ; return (occ_env', new_external_name) }++  | otherwise = panic "tidyTopName"+  where+    name        = idName id+    external    = isJust maybe_ref+    global      = isExternalName name+    local       = not global+    internal    = not external+    loc         = nameSrcSpan name++    old_occ     = nameOccName name+    new_occ | Just ref <- maybe_ref+            , ref /= id+            = mkOccName (occNameSpace old_occ) $+                   let+                       ref_str = occNameString (getOccName ref)+                       occ_str = occNameString old_occ+                   in+                   case occ_str of+                     '$':'w':_ -> occ_str+                        -- workers: the worker for a function already+                        -- includes the occname for its parent, so there's+                        -- no need to prepend the referrer.+                     _other | isSystemName name -> ref_str+                            | otherwise         -> ref_str ++ '_' : occ_str+                        -- If this name was system-generated, then don't bother+                        -- to retain its OccName, just use the referrer.  These+                        -- system-generated names will become "f1", "f2", etc. for+                        -- a referrer "f".+            | otherwise = old_occ++    (occ_env', occ') = tidyOccName occ_env new_occ++    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)+                    where+                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)++    mk_new_external nc = allocateGlobalBinder nc mod occ' loc+        -- If we want to externalise a currently-local name, check+        -- whether we have already assigned a unique for it.+        -- If so, use it; if not, extend the table.+        -- All this is done by allcoateGlobalBinder.+        -- This is needed when *re*-compiling a module in GHCi; we must+        -- use the same name for externally-visible things as we did before.++{-+************************************************************************+*                                                                      *+\subsection{Step 2: top-level tidying}+*                                                                      *+************************************************************************+-}++-- TopTidyEnv: when tidying we need to know+--   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.+--        These may have arisen because the+--        renamer read in an interface file mentioning M.$wf, say,+--        and assigned it unique r77.  If, on this compilation, we've+--        invented an Id whose name is $wf (but with a different unique)+--        we want to rename it to have unique r77, so that we can do easy+--        comparisons with stuff from the interface file+--+--   * occ_env: The TidyOccEnv, which tells us which local occurrences+--     are 'used'+--+--   * subst_env: A Var->Var mapping that substitutes the new Var for the old++tidyTopBinds :: HscEnv+             -> Module+             -> UnfoldEnv+             -> TidyOccEnv+             -> CoreProgram+             -> IO (TidyEnv, CoreProgram)++tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds+  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env+       mkNaturalId <- lookupMkNaturalName dflags hsc_env+       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env+       let cvt_literal nt i = case nt of+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)+             _             -> Nothing+           result      = tidy cvt_literal init_env binds+       seqBinds (snd result) `seq` return result+       -- This seqBinds avoids a spike in space usage (see #13564)+  where+    dflags = hsc_dflags hsc_env++    init_env = (init_occ_env, emptyVarEnv)++    tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env)++------------------------+tidyTopBind  :: DynFlags+             -> Module+             -> (LitNumType -> Integer -> Maybe CoreExpr)+             -> UnfoldEnv+             -> TidyEnv+             -> CoreBind+             -> (TidyEnv, CoreBind)++tidyTopBind dflags this_mod cvt_literal unfold_env+            (occ_env,subst1) (NonRec bndr rhs)+  = (tidy_env2,  NonRec bndr' rhs')+  where+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr+    caf_info      = hasCafRefs dflags this_mod+                               (subst1, cvt_literal)+                               (idArity bndr) rhs+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'+                                (bndr, rhs)+    subst2        = extendVarEnv subst1 bndr bndr'+    tidy_env2     = (occ_env, subst2)++tidyTopBind dflags this_mod cvt_literal unfold_env+            (occ_env, subst1) (Rec prs)+  = (tidy_env2, Rec prs')+  where+    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)+           | (id,rhs) <- prs,+             let (name',show_unfold) =+                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id+           ]++    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')+    tidy_env2 = (occ_env, subst2)++    bndrs = map fst prs++        -- the CafInfo for a recursive group says whether *any* rhs in+        -- the group may refer indirectly to a CAF (because then, they all do).+    caf_info+        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod+                                          (subst1, cvt_literal)+                                          (idArity bndr) rhs)+             | (bndr,rhs) <- prs ] = MayHaveCafRefs+        | otherwise                = NoCafRefs++-----------------------------------------------------------+tidyTopPair :: DynFlags+            -> Bool  -- show unfolding+            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo+                        -- It is knot-tied: don't look at it!+            -> CafInfo+            -> Name             -- New name+            -> (Id, CoreExpr)   -- Binder and RHS before tidying+            -> (Id, CoreExpr)+        -- This function is the heart of Step 2+        -- The rec_tidy_env is the one to use for the IdInfo+        -- It's necessary because when we are dealing with a recursive+        -- group, a variable late in the group might be mentioned+        -- in the IdInfo of one early in the group++tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)+  = (bndr1, rhs1)+  where+    bndr1    = mkGlobalId details name' ty' idinfo'+    details  = idDetails bndr   -- Preserve the IdDetails+    ty'      = tidyTopType (idType bndr)+    rhs1     = tidyExpr rhs_tidy_env rhs+    idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)+                             show_unfold caf_info++-- tidyTopIdInfo creates the final IdInfo for top-level+-- binders.  There are two delicate pieces:+--+--  * Arity.  After CoreTidy, this arity must not change any more.+--      Indeed, CorePrep must eta expand where necessary to make+--      the manifest arity equal to the claimed arity.+--+--  * CAF info.  This must also remain valid through to code generation.+--      We add the info here so that it propagates to all+--      occurrences of the binders in RHSs, and hence to occurrences in+--      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.+--      CoreToStg makes use of this when constructing SRTs.+tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr+              -> IdInfo -> Bool -> CafInfo -> IdInfo+tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info+  | not is_external     -- For internal Ids (not externally visible)+  = vanillaIdInfo       -- we only need enough info for code generation+                        -- Arity and strictness info are enough;+                        --      c.f. CoreTidy.tidyLetBndr+        `setCafInfo`        caf_info+        `setArityInfo`      arity+        `setStrictnessInfo` final_sig+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]+                                                 -- in CoreTidy++  | otherwise           -- Externally-visible Ids get the whole lot+  = vanillaIdInfo+        `setCafInfo`           caf_info+        `setArityInfo`         arity+        `setStrictnessInfo`    final_sig+        `setOccInfo`           robust_occ_info+        `setInlinePragInfo`    (inlinePragInfo idinfo)+        `setUnfoldingInfo`     unfold_info+                -- NB: we throw away the Rules+                -- They have already been extracted by findExternalRules+  where+    is_external = isExternalName name++    --------- OccInfo ------------+    robust_occ_info = zapFragileOcc (occInfo idinfo)+    -- It's important to keep loop-breaker information+    -- when we are doing -fexpose-all-unfoldings++    --------- Strictness ------------+    mb_bot_str = exprBotStrictness_maybe orig_rhs++    sig = strictnessInfo idinfo+    final_sig | not $ isTopSig sig+              = WARN( _bottom_hidden sig , ppr name ) sig+              -- try a cheap-and-cheerful bottom analyser+              | Just (_, nsig) <- mb_bot_str = nsig+              | otherwise                    = sig++    _bottom_hidden id_sig = case mb_bot_str of+                                  Nothing         -> False+                                  Just (arity, _) -> not (appIsBottom id_sig arity)++    --------- Unfolding ------------+    unf_info = unfoldingInfo idinfo+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs+                | otherwise   = minimal_unfold_info+    minimal_unfold_info = zapUnfolding unf_info+    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs+    is_bot = isBottomingSig final_sig+    -- NB: do *not* expose the worker if show_unfold is off,+    --     because that means this thing is a loop breaker or+    --     marked NOINLINE or something like that+    -- This is important: if you expose the worker for a loop-breaker+    -- then you can make the simplifier go into an infinite loop, because+    -- in effect the unfolding is exposed.  See #1709+    --+    -- You might think that if show_unfold is False, then the thing should+    -- not be w/w'd in the first place.  But a legitimate reason is this:+    --    the function returns bottom+    -- In this case, show_unfold will be false (we don't expose unfoldings+    -- for bottoming functions), but we might still have a worker/wrapper+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs+++    --------- Arity ------------+    -- Usually the Id will have an accurate arity on it, because+    -- the simplifier has just run, but not always.+    -- One case I found was when the last thing the simplifier+    -- did was to let-bind a non-atomic argument and then float+    -- it to the top level. So it seems more robust just to+    -- fix it here.+    arity = exprArity orig_rhs++{-+************************************************************************+*                                                                      *+           Figuring out CafInfo for an expression+*                                                                      *+************************************************************************++hasCafRefs decides whether a top-level closure can point into the dynamic heap.+We mark such things as `MayHaveCafRefs' because this information is+used to decide whether a particular closure needs to be referenced+in an SRT or not.++There are two reasons for setting MayHaveCafRefs:+        a) The RHS is a CAF: a top-level updatable thunk.+        b) The RHS refers to something that MayHaveCafRefs++Possible improvement: In an effort to keep the number of CAFs (and+hence the size of the SRTs) down, we could also look at the expression and+decide whether it requires a small bounded amount of heap, so we can ignore+it as a CAF.  In these cases however, we would need to use an additional+CAF list to keep track of non-collectable CAFs.++Note [Disgusting computation of CafRefs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compute hasCafRefs here, because IdInfo is supposed to be finalised+after tidying. But CorePrep does some transformations that affect CAF-hood.+So we have to *predict* the result here, which is revolting.++In particular CorePrep expands Integer and Natural literals. So in the+prediction code here we resort to applying the same expansion (cvt_literal).+There are also numerous other ways in which we can introduce inconsistencies+between CorePrep and GHC.Iface.Tidy. See Note [CAFfyness inconsistencies due to+eta expansion in TidyPgm] for one such example.++Ugh! What ugliness we hath wrought.+++Note [CAFfyness inconsistencies due to eta expansion in TidyPgm]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Eta expansion during CorePrep can have non-obvious negative consequences on+the CAFfyness computation done by tidying (see Note [Disgusting computation of+CafRefs] in GHC.Iface.Tidy). This late expansion happens/happened for a few+reasons:++ * CorePrep previously eta expanded unsaturated primop applications, as+   described in Note [Primop wrappers]).++ * CorePrep still does eta expand unsaturated data constructor applications.++In particular, consider the program:++    data Ty = Ty (RealWorld# -> (# RealWorld#, Int #))++    -- Is this CAFfy?+    x :: STM Int+    x = Ty (retry# @Int)++Consider whether x is CAFfy. One might be tempted to answer "no".+Afterall, f obviously has no CAF references and the application (retry#+@Int) is essentially just a variable reference at runtime.++However, when CorePrep expanded the unsaturated application of 'retry#'+it would rewrite this to++    x = \u []+       let sat = retry# @Int+       in Ty sat++This is now a CAF. Failing to handle this properly was the cause of+#16846. We fixed this by eliminating the need to eta expand primops, as+described in Note [Primop wrappers]), However we have not yet done the same for+data constructor applications.++-}++type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)+  -- The env finds the Caf-ness of the Id+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for+  -- Integer and Natural literals+  -- See Note [Disgusting computation of CafRefs]++hasCafRefs :: DynFlags -> Module+           -> CafRefEnv -> Arity -> CoreExpr+           -> CafInfo+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr+  | is_caf || mentions_cafs = MayHaveCafRefs+  | otherwise               = NoCafRefs+ where+  mentions_cafs   = cafRefsE expr+  is_dynamic_name = isDllName dflags this_mod+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name+                                         cvt_literal expr)++  -- NB. we pass in the arity of the expression, which is expected+  -- to be calculated by exprArity.  This is because exprArity+  -- knows how much eta expansion is going to be done by+  -- CorePrep later on, and we don't want to duplicate that+  -- knowledge in rhsIsStatic below.++  cafRefsE :: Expr a -> Bool+  cafRefsE (Var id)            = cafRefsV id+  cafRefsE (Lit lit)           = cafRefsL lit+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a+  cafRefsE (Lam _ e)           = cafRefsE e+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)+  cafRefsE (Tick _n e)         = cafRefsE e+  cafRefsE (Cast e _co)        = cafRefsE e+  cafRefsE (Type _)            = False+  cafRefsE (Coercion _)        = False++  cafRefsEs :: [Expr a] -> Bool+  cafRefsEs []     = False+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es++  cafRefsL :: Literal -> Bool+  -- Don't forget that mk_integer id might have Caf refs!+  -- We first need to convert the Integer into its final form, to+  -- see whether mkInteger is used. Same for LitNatural.+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of+    Just e  -> cafRefsE e+    Nothing -> False+  cafRefsL _                = False++  cafRefsV :: Id -> Bool+  cafRefsV id+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')+    | otherwise                         = False+++{-+************************************************************************+*                                                                      *+                  Old, dead, type-trimming code+*                                                                      *+************************************************************************++We used to try to "trim off" the constructors of data types that are+not exported, to reduce the size of interface files, at least without+-O.  But that is not always possible: see the old Note [When we can't+trim types] below for exceptions.++Then (#7445) I realised that the TH problem arises for any data type+that we have deriving( Data ), because we can invoke+   Language.Haskell.TH.Quote.dataToExpQ+to get a TH Exp representation of a value built from that data type.+You don't even need {-# LANGUAGE TemplateHaskell #-}.++At this point I give up. The pain of trimming constructors just+doesn't seem worth the gain.  So I've dumped all the code, and am just+leaving it here at the end of the module in case something like this+is ever resurrected.+++Note [When we can't trim types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of type trimming is to export algebraic data types+abstractly (without their data constructors) when compiling without+-O, unless of course they are explicitly exported by the user.++We always export synonyms, because they can be mentioned in the type+of an exported Id.  We could do a full dependency analysis starting+from the explicit exports, but that's quite painful, and not done for+now.++But there are some times we can't do that, indicated by the 'no_trim_types' flag.++First, Template Haskell.  Consider (#2386) this+        module M(T, makeOne) where+          data T = Yay String+          makeOne = [| Yay "Yep" |]+Notice that T is exported abstractly, but makeOne effectively exports it too!+A module that splices in $(makeOne) will then look for a declaration of Yay,+so it'd better be there.  Hence, brutally but simply, we switch off type+constructor trimming if TH is enabled in this module.++Second, data kinds.  Consider (#5912)+     {-# LANGUAGE DataKinds #-}+     module M() where+     data UnaryTypeC a = UnaryDataC a+     type Bug = 'UnaryDataC+We always export synonyms, so Bug is exposed, and that means that+UnaryTypeC must be too, even though it's not explicitly exported.  In+effect, DataKinds means that we'd need to do a full dependency analysis+to see what data constructors are mentioned.  But we don't do that yet.++In these two cases we just switch off type trimming altogether.++mustExposeTyCon :: Bool         -- Type-trimming flag+                -> NameSet      -- Exports+                -> TyCon        -- The tycon+                -> Bool         -- Can its rep be hidden?+-- We are compiling without -O, and thus trying to write as little as+-- possible into the interface file.  But we must expose the details of+-- any data types whose constructors or fields are exported+mustExposeTyCon no_trim_types exports tc+  | no_trim_types               -- See Note [When we can't trim types]+  = True++  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to+                                -- figure out whether it was mentioned in the type+                                -- of any other exported thing)+  = True++  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors+  = True                        -- won't lead to the need for further exposure++  | isFamilyTyCon tc            -- Open type family+  = True++  -- Below here we just have data/newtype decls or family instances++  | null data_cons              -- Ditto if there are no data constructors+  = True                        -- (NB: empty data types do not count as enumerations+                                -- see Note [Enumeration types] in TyCon++  | any exported_con data_cons  -- Expose rep if any datacon or field is exported+  = True++  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))+  = True   -- Expose the rep for newtypes if the rep is an FFI type.+           -- For a very annoying reason.  'Foreign import' is meant to+           -- be able to look through newtypes transparently, but it+           -- can only do that if it can "see" the newtype representation++  | otherwise+  = False+  where+    data_cons = tyConDataCons tc+    exported_con con = any (`elemNameSet` exports)+                           (dataConName con : dataConFieldLabels con)+-}
+ compiler/GHC/Iface/Utils.hs view
@@ -0,0 +1,2078 @@+{-+(c) The University of Glasgow 2006-2008+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+-}++{-# LANGUAGE CPP, NondecreasingIndentation #-}+{-# LANGUAGE MultiWayIf #-}++-- | Module for constructing @ModIface@ values (interface files),+-- writing them to disk and comparing two versions to see if+-- recompilation is required.+module GHC.Iface.Utils (+        mkPartialIface,+        mkFullIface,++        mkIfaceTc,++        writeIfaceFile, -- Write the interface file++        checkOldIface,  -- See if recompilation is required, by+                        -- comparing version information+        RecompileRequired(..), recompileRequired,+        mkIfaceExports,++        coAxiomToIfaceDecl,+        tyThingToIfaceDecl -- Converting things to their Iface equivalents+ ) where++{-+  -----------------------------------------------+          Recompilation checking+  -----------------------------------------------++A complete description of how recompilation checking works can be+found in the wiki commentary:++ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance++Please read the above page for a top-down description of how this all+works.  Notes below cover specific issues related to the implementation.++Basic idea:++  * In the mi_usages information in an interface, we record the+    fingerprint of each free variable of the module++  * In mkIface, we compute the fingerprint of each exported thing A.f.+    For each external thing that A.f refers to, we include the fingerprint+    of the external reference when computing the fingerprint of A.f.  So+    if anything that A.f depends on changes, then A.f's fingerprint will+    change.+    Also record any dependent files added with+      * addDependentFile+      * #include+      * -optP-include++  * In checkOldIface we compare the mi_usages for the module with+    the actual fingerprint for all each thing recorded in mi_usages+-}++#include "HsVersions.h"++import GhcPrelude++import GHC.Iface.Syntax+import BinFingerprint+import GHC.Iface.Load+import GHC.CoreToIface+import FlagChecker++import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )+import Id+import Annotations+import CoreSyn+import Class+import TyCon+import CoAxiom+import ConLike+import DataCon+import Type+import TcType+import InstEnv+import FamInstEnv+import TcRnMonad+import GHC.Hs+import HscTypes+import Finder+import DynFlags+import VarEnv+import Var+import Name+import Avail+import RdrName+import NameEnv+import NameSet+import Module+import GHC.Iface.Binary+import ErrUtils+import Digraph+import SrcLoc+import Outputable+import BasicTypes       hiding ( SuccessFlag(..) )+import Unique+import Util             hiding ( eqListBy )+import FastString+import Maybes+import Binary+import Fingerprint+import Exception+import UniqSet+import Packages+import ExtractDocs++import Control.Monad+import Data.Function+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Ord+import Data.IORef+import System.Directory+import System.FilePath+import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),+                 pluginRecompile', plugins )++--Qualified import so we can define a Semigroup instance+-- but it doesn't clash with Outputable.<>+import qualified Data.Semigroup++{-+************************************************************************+*                                                                      *+\subsection{Completing an interface}+*                                                                      *+************************************************************************+-}++mkPartialIface :: HscEnv+               -> ModDetails+               -> ModGuts+               -> PartialModIface+mkPartialIface hsc_env mod_details+  ModGuts{ mg_module       = this_mod+         , mg_hsc_src      = hsc_src+         , mg_usages       = usages+         , mg_used_th      = used_th+         , mg_deps         = deps+         , mg_rdr_env      = rdr_env+         , mg_fix_env      = fix_env+         , mg_warns        = warns+         , mg_hpc_info     = hpc_info+         , mg_safe_haskell = safe_mode+         , mg_trust_pkg    = self_trust+         , mg_doc_hdr      = doc_hdr+         , mg_decl_docs    = decl_docs+         , mg_arg_docs     = arg_docs+         }+  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust+             safe_mode usages doc_hdr decl_docs arg_docs mod_details++-- | Fully instantiate a interface+-- Adds fingerprints and potentially code generator produced information.+mkFullIface :: HscEnv -> PartialModIface -> IO ModIface+mkFullIface hsc_env partial_iface = do+    full_iface <-+      {-# SCC "addFingerprints" #-}+      addFingerprints hsc_env partial_iface++    -- Debug printing+    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)++    return full_iface++-- | Make an interface from the results of typechecking only.  Useful+-- for non-optimising compilation, or where we aren't generating any+-- object code at all ('HscNothing').+mkIfaceTc :: HscEnv+          -> SafeHaskellMode    -- The safe haskell mode+          -> ModDetails         -- gotten from mkBootModDetails, probably+          -> TcGblEnv           -- Usages, deprecations, etc+          -> IO ModIface+mkIfaceTc hsc_env safe_mode mod_details+  tc_result@TcGblEnv{ tcg_mod = this_mod,+                      tcg_src = hsc_src,+                      tcg_imports = imports,+                      tcg_rdr_env = rdr_env,+                      tcg_fix_env = fix_env,+                      tcg_merged = merged,+                      tcg_warns = warns,+                      tcg_hpc = other_hpc_info,+                      tcg_th_splice_used = tc_splice_used,+                      tcg_dependent_files = dependent_files+                    }+  = do+          let used_names = mkUsedNames tc_result+          let pluginModules =+                map lpModule (cachedPlugins (hsc_dflags hsc_env))+          deps <- mkDependencies+                    (thisInstalledUnitId (hsc_dflags hsc_env))+                    (map mi_module pluginModules) tc_result+          let hpc_info = emptyHpcInfo other_hpc_info+          used_th <- readIORef tc_splice_used+          dep_files <- (readIORef dependent_files)+          -- Do NOT use semantic module here; this_mod in mkUsageInfo+          -- is used solely to decide if we should record a dependency+          -- or not.  When we instantiate a signature, the semantic+          -- module is something we want to record dependencies for,+          -- but if you pass that in here, we'll decide it's the local+          -- module and does not need to be recorded as a dependency.+          -- See Note [Identity versus semantic module]+          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names+                      dep_files merged pluginModules++          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result++          let partial_iface = mkIface_ hsc_env+                   this_mod hsc_src+                   used_th deps rdr_env+                   fix_env warns hpc_info+                   (imp_trust_own_pkg imports) safe_mode usages+                   doc_hdr' doc_map arg_map+                   mod_details++          mkFullIface hsc_env partial_iface++mkIface_ :: HscEnv -> Module -> HscSource+         -> Bool -> Dependencies -> GlobalRdrEnv+         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> Bool+         -> SafeHaskellMode+         -> [Usage]+         -> Maybe HsDocString+         -> DeclDocMap+         -> ArgDocMap+         -> ModDetails+         -> PartialModIface+mkIface_ hsc_env+         this_mod hsc_src used_th deps rdr_env fix_env src_warns+         hpc_info pkg_trust_req safe_mode usages+         doc_hdr decl_docs arg_docs+         ModDetails{  md_insts     = insts,+                      md_fam_insts = fam_insts,+                      md_rules     = rules,+                      md_anns      = anns,+                      md_types     = type_env,+                      md_exports   = exports,+                      md_complete_sigs = complete_sigs }+-- NB:  notice that mkIface does not look at the bindings+--      only at the TypeEnv.  The previous Tidy phase has+--      put exactly the info into the TypeEnv that we want+--      to expose in the interface++  = do+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)+        entities = typeEnvElts type_env+        decls  = [ tyThingToIfaceDecl entity+                 | entity <- entities,+                   let name = getName entity,+                   not (isImplicitTyThing entity),+                      -- No implicit Ids and class tycons in the interface file+                   not (isWiredInName name),+                      -- Nor wired-in things; the compiler knows about them anyhow+                   nameIsLocalOrFrom semantic_mod name  ]+                      -- Sigh: see Note [Root-main Id] in TcRnDriver+                      -- NB: ABSOLUTELY need to check against semantic_mod,+                      -- because all of the names in an hsig p[H=<H>]:H+                      -- are going to be for <H>, not the former id!+                      -- 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+          -- deterministic, so we sort by OccName to canonicalize it.+          -- See Note [Deterministic UniqFM] in UniqDFM for more details.+        warns       = src_warns+        iface_rules = map coreRuleToIfaceRule rules+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts+        iface_fam_insts = map famInstToIfaceFamInst fam_insts+        trust_info  = setSafeMode safe_mode+        annotations = map mkIfaceAnnotation anns+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs++    ModIface {+          mi_module      = this_mod,+          -- Need to record this because it depends on the -instantiated-with flag+          -- which could change+          mi_sig_of      = if semantic_mod == this_mod+                            then Nothing+                            else Just semantic_mod,+          mi_hsc_src     = hsc_src,+          mi_deps        = deps,+          mi_usages      = usages,+          mi_exports     = mkIfaceExports exports,++          -- Sort these lexicographically, so that+          -- the result is stable across compilations+          mi_insts       = sortBy cmp_inst     iface_insts,+          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,+          mi_rules       = sortBy cmp_rule     iface_rules,++          mi_fixities    = fixities,+          mi_warns       = warns,+          mi_anns        = annotations,+          mi_globals     = maybeGlobalRdrEnv rdr_env,+          mi_used_th     = used_th,+          mi_decls       = decls,+          mi_hpc         = isHpcUsed hpc_info,+          mi_trust       = trust_info,+          mi_trust_pkg   = pkg_trust_req,+          mi_complete_sigs = icomplete_sigs,+          mi_doc_hdr     = doc_hdr,+          mi_decl_docs   = decl_docs,+          mi_arg_docs    = arg_docs,+          mi_final_exts  = () }+  where+     cmp_rule     = comparing ifRuleName+     -- Compare these lexicographically by OccName, *not* by unique,+     -- because the latter is not stable across compilations:+     cmp_inst     = comparing (nameOccName . ifDFun)+     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)++     dflags = hsc_dflags hsc_env++     -- We only fill in mi_globals if the module was compiled to byte+     -- code.  Otherwise, the compiler may not have retained all the+     -- top-level bindings and they won't be in the TypeEnv (see+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used+     -- by GHCi to decide whether the module has its full top-level+     -- scope available. (#5534)+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv+     maybeGlobalRdrEnv rdr_env+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env+         | otherwise                                   = Nothing++     ifFamInstTcName = ifFamInstFam++-----------------------------+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()+writeIfaceFile dflags hi_file_path new_iface+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)+         writeBinIface dflags hi_file_path new_iface+++-- -----------------------------------------------------------------------------+-- Look up parents and versions of Names++-- This is like a global version of the mi_hash_fn field in each ModIface.+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get+-- the parent and version info.++mkHashFun+        :: HscEnv                       -- needed to look up versions+        -> ExternalPackageState         -- ditto+        -> (Name -> IO Fingerprint)+mkHashFun hsc_env eps name+  | isHoleModule orig_mod+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))+  | otherwise+  = lookup orig_mod+  where+      dflags = hsc_dflags hsc_env+      hpt = hsc_HPT hsc_env+      pit = eps_PIT eps+      occ = nameOccName name+      orig_mod = nameModule name+      lookup mod = do+        MASSERT2( isExternalName name, ppr name )+        iface <- case lookupIfaceByModule hpt pit mod of+                  Just iface -> return iface+                  Nothing -> do+                      -- This can occur when we're writing out ifaces for+                      -- requirements; we didn't do any /real/ typechecking+                      -- so there's no guarantee everything is loaded.+                      -- Kind of a heinous hack.+                      iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "lookupVers2") mod ImportBySystem+                      return iface+        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))++-- ---------------------------------------------------------------------------+-- Compute fingerprints for the interface++{-+Note [Fingerprinting IfaceDecls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The general idea here is that we first examine the 'IfaceDecl's and determine+the recursive groups of them. We then walk these groups in dependency order,+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then+hash using MD5 to produce a fingerprint for the group.++However, the serialization that we use is a bit funny: we override the @putName@+operation with our own which serializes the hash of a 'Name' instead of the+'Name' itself. This ensures that the fingerprint of a decl changes if anything+in its transitive closure changes. This trick is why we must be careful about+traversing in dependency order: we need to ensure that we have hashes for+everything referenced by the decl which we are fingerprinting.++Moreover, we need to be careful to distinguish between serialization of binding+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls+field of a IfaceClsInst): only in the non-binding case should we include the+fingerprint; in the binding case we shouldn't since it is merely the name of the+thing that we are currently fingerprinting.+-}++-- | Add fingerprints for top-level declarations to a 'ModIface'.+--+-- See Note [Fingerprinting IfaceDecls]+addFingerprints+        :: HscEnv+        -> PartialModIface+        -> IO ModIface+addFingerprints hsc_env iface0+ = do+   eps <- hscEPS hsc_env+   let+       decls = mi_decls iface0+       warn_fn = mkIfaceWarnCache (mi_warns iface0)+       fix_fn = mkIfaceFixCache (mi_fixities iface0)++        -- The ABI of a declaration represents everything that is made+        -- visible about the declaration that a client can depend on.+        -- see IfaceDeclABI below.+       declABI :: IfaceDecl -> IfaceDeclABI+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.+       -- See also Note [Identity versus semantic module]+       declABI decl = (this_mod, decl, extras)+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts+                                  non_orph_fis top_lvl_name_env decl++       -- This is used for looking up the Name of a default method+       -- from its OccName. See Note [default method Name]+       top_lvl_name_env =+         mkOccEnv [ (nameOccName nm, nm)+                  | IfaceId { ifName = nm } <- decls ]++       -- Dependency edges between declarations in the current module.+       -- This is computed by finding the free external names of each+       -- declaration, including IfaceDeclExtras (things that a+       -- declaration implicitly depends on).+       edges :: [ Node Unique IfaceDeclABI ]+       edges = [ DigraphNode abi (getUnique (getOccName decl)) out+               | decl <- decls+               , let abi = declABI decl+               , let out = localOccs $ freeNamesDeclABI abi+               ]++       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       localOccs =+         map (getUnique . getParent . getOccName)+                        -- NB: names always use semantic module, so+                        -- filtering must be on the semantic module!+                        -- See Note [Identity versus semantic module]+                        . filter ((== semantic_mod) . name_module)+                        . nonDetEltsUniqSet+                   -- It's OK to use nonDetEltsUFM as localOccs is only+                   -- used to construct the edges and+                   -- stronglyConnCompFromEdgedVertices is deterministic+                   -- even with non-deterministic order of edges as+                   -- explained in Note [Deterministic SCC] in Digraph.+          where getParent :: OccName -> OccName+                getParent occ = lookupOccEnv parent_map occ `orElse` occ++        -- maps OccNames to their parents in the current module.+        -- e.g. a reference to a constructor must be turned into a reference+        -- to the TyCon for the purposes of calculating dependencies.+       parent_map :: OccEnv OccName+       parent_map = foldl' extend emptyOccEnv decls+          where extend env d =+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]+                  where n = getOccName d++        -- Strongly-connected groups of declarations, in dependency order+       groups :: [SCC IfaceDeclABI]+       groups = stronglyConnCompFromEdgedVerticesUniq edges++       global_hash_fn = mkHashFun hsc_env eps++        -- How to output Names when generating the data to fingerprint.+        -- Here we want to output the fingerprint for each top-level+        -- Name, whether it comes from the current module or another+        -- module.  In this way, the fingerprint for a declaration will+        -- change if the fingerprint for anything it refers to (transitively)+        -- changes.+       mk_put_name :: OccEnv (OccName,Fingerprint)+                   -> BinHandle -> Name -> IO  ()+       mk_put_name local_env bh name+          | isWiredInName name  =  putNameLiterally bh name+           -- wired-in names don't have fingerprints+          | otherwise+          = ASSERT2( isExternalName name, ppr name )+            let hash | nameModule name /= semantic_mod =  global_hash_fn name+                     -- Get it from the REAL interface!!+                     -- This will trigger when we compile an hsig file+                     -- and we know a backing impl for it.+                     -- See Note [Identity versus semantic module]+                     | semantic_mod /= this_mod+                     , not (isHoleModule semantic_mod) = global_hash_fn name+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)+                           `orElse` pprPanic "urk! lookup local fingerprint"+                                       (ppr name $$ ppr local_env)))+                -- This panic indicates that we got the dependency+                -- analysis wrong, because we needed a fingerprint for+                -- an entity that wasn't in the environment.  To debug+                -- it, turn the panic into a trace, uncomment the+                -- pprTraces below, run the compile again, and inspect+                -- the output and the generated .hi file with+                -- --show-iface.+            in hash >>= put_ bh++        -- take a strongly-connected group of declarations and compute+        -- its fingerprint.++       fingerprint_group :: (OccEnv (OccName,Fingerprint),+                             [(Fingerprint,IfaceDecl)])+                         -> SCC IfaceDeclABI+                         -> IO (OccEnv (OccName,Fingerprint),+                                [(Fingerprint,IfaceDecl)])++       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)+          = do let hash_fn = mk_put_name local_env+                   decl = abiDecl abi+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do+               hash <- computeFingerprint hash_fn abi+               env' <- extend_hash_env local_env (hash,decl)+               return (env', (hash,decl) : decls_w_hashes)++       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)+          = do let decls = map abiDecl abis+               local_env1 <- foldM extend_hash_env local_env+                                   (zip (repeat fingerprint0) decls)+               let hash_fn = mk_put_name local_env1+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do+               let stable_abis = sortBy cmp_abiNames abis+                -- put the cycle in a canonical order+               hash <- computeFingerprint hash_fn stable_abis+               let pairs = zip (repeat hash) decls+               local_env2 <- foldM extend_hash_env local_env pairs+               return (local_env2, pairs ++ decls_w_hashes)++       -- we have fingerprinted the whole declaration, but we now need+       -- to assign fingerprints to all the OccNames that it binds, to+       -- use when referencing those OccNames in later declarations.+       --+       extend_hash_env :: OccEnv (OccName,Fingerprint)+                       -> (Fingerprint,IfaceDecl)+                       -> IO (OccEnv (OccName,Fingerprint))+       extend_hash_env env0 (hash,d) = do+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0+                 (ifaceDeclFingerprints hash d))++   --+   (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:+   let sorted_deps = sortDependencies (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+   -- that changes in orphans get propagated all the way up the+   -- dependency tree.+   --+   -- Note [A bad dep_orphs optimization]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- In a previous version of this code, we filtered out orphan modules which+   -- were not from the home package, justifying it by saying that "we'd+   -- pick up the ABI hashes of the external module instead".  This is wrong.+   -- Suppose that we have:+   --+   --       module External where+   --           instance Show (a -> b)+   --+   --       module Home1 where+   --           import External+   --+   --       module Home2 where+   --           import Home1+   --+   -- The export hash of Home1 needs to reflect the orphan instances of+   -- External. It's true that Home1 will get rebuilt if the orphans+   -- of External, but we also need to make sure Home2 gets rebuilt+   -- as well.  See #12733 for more details.+   let orph_mods+        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]+        $ dep_orphs sorted_deps+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods++   -- Note [Do not update EPS with your own hi-boot]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- (See also #10182).  When your hs-boot file includes an orphan+   -- instance declaration, you may find that the dep_orphs of a module you+   -- import contains reference to yourself.  DO NOT actually load this module+   -- or add it to the orphan hashes: you're going to provide the orphan+   -- instances yourself, no need to consult hs-boot; if you do load the+   -- interface into EPS, you will see a duplicate orphan instance.++   orphan_hash <- computeFingerprint (mk_put_name local_env)+                                     (map ifDFun orph_insts, orph_rules, orph_fis)++   -- the export list hash doesn't depend on the fingerprints of+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.+   export_hash <- computeFingerprint putNameLiterally+                      (mi_exports iface0,+                       orphan_hash,+                       dep_orphan_hashes,+                       dep_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                       dep_finsts (mi_deps iface0),+                        -- dep_pkgs: see "Package Version Changes" on+                        -- wiki/commentary/compiler/recompilation-avoidance+                       mi_trust iface0)+                        -- Make sure change of Safe Haskell mode causes recomp.++   -- Note [Export hash depends on non-orphan family instances]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   --+   -- Suppose we have:+   --+   --   module A where+   --       type instance F Int = Bool+   --+   --   module B where+   --       import A+   --+   --   module C where+   --       import B+   --+   -- The family instance consistency check for C depends on the dep_finsts of+   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need+   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of+   -- the exports of B, because C always considers them when checking+   -- consistency.+   --+   -- A full discussion is in #12723.+   --+   -- We do NOT need to hash dep_orphs, because this is implied by+   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,+   -- because there is no eager consistency check as there is with type families+   -- (also we didn't store it anywhere!)+   --++   -- put the declarations in a canonical order, sorted by OccName+   let sorted_decls = Map.elems $ Map.fromList $+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]++   -- the flag hash depends on:+   --   - (some of) dflags+   -- it returns two hashes, one that shouldn't change+   -- the abi hash and one that should+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally++   opt_hash <- fingerprintOptFlags dflags putNameLiterally++   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally++   plugin_hash <- fingerprintPlugins hsc_env++   -- the ABI hash depends on:+   --   - decls+   --   - export list+   --   - orphans+   --   - deprecations+   --   - flag abi hash+   mod_hash <- computeFingerprint putNameLiterally+                      (map fst sorted_decls,+                       export_hash,  -- includes orphan_hash+                       mi_warns iface0)++   -- The interface hash depends on:+   --   - the ABI hash, plus+   --   - the module level annotations,+   --   - usages+   --   - deps (home and external packages, dependent files)+   --   - hpc+   iface_hash <- computeFingerprint putNameLiterally+                      (mod_hash,+                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache+                       mi_usages iface0,+                       sorted_deps,+                       mi_hpc iface0)++   let+    final_iface_exts = ModIfaceBackend+      { mi_iface_hash  = iface_hash+      , mi_mod_hash    = mod_hash+      , mi_flag_hash   = flag_hash+      , mi_opt_hash    = opt_hash+      , mi_hpc_hash    = hpc_hash+      , mi_plugin_hash = plugin_hash+      , mi_orphan      = not (   all ifRuleAuto orph_rules+                                   -- See Note [Orphans and auto-generated rules]+                              && null orph_insts+                              && null orph_fis)+      , mi_finsts      = not (null (mi_fam_insts iface0))+      , mi_exp_hash    = export_hash+      , mi_orphan_hash = orphan_hash+      , mi_warn_fn     = warn_fn+      , mi_fix_fn      = fix_fn+      , mi_hash_fn     = lookupOccEnv local_env+      }+    final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }+   --+   return final_iface++  where+    this_mod = mi_module iface0+    semantic_mod = mi_semantic_module iface0+    dflags = hsc_dflags hsc_env+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)+    ann_fn = mkIfaceAnnCache (mi_anns iface0)++-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules+-- (in particular, the orphan modules which are transitively imported by the+-- current module).+--+-- Q: Why do we need the hash at all, doesn't the list of transitively+-- imported orphan modules suffice?+--+-- A: If one of our transitive imports adds a new orphan instance, our+-- export hash must change so that modules which import us rebuild.  If we just+-- hashed the [Module], the hash would not change even when a new instance was+-- added to a module that already had an orphan instance.+--+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?+-- Why the full transitive closure?+--+-- A: Suppose we have these modules:+--+--      module A where+--          instance Show (a -> b) where+--      module B where+--          import A -- **+--      module C where+--          import A+--          import B+--+-- Whether or not we add or remove the import to A in B affects the+-- orphan hash of B.  But it shouldn't really affect the orphan hash+-- of C.  If we hashed only direct dependencies, there would be no+-- way to tell that the net effect was a wash, and we'd be forced+-- to recompile C and everything else.+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]+getOrphanHashes hsc_env mods = do+  eps <- hscEPS hsc_env+  let+    hpt        = hsc_HPT hsc_env+    pit        = eps_PIT eps+    get_orph_hash mod =+          case lookupIfaceByModule hpt pit mod of+            Just iface -> return (mi_orphan_hash (mi_final_exts iface))+            Nothing    -> do -- similar to 'mkHashFun'+                iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem+                return (mi_orphan_hash (mi_final_exts iface))++  --+  mapM get_orph_hash mods+++sortDependencies :: Dependencies -> Dependencies+sortDependencies d+ = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),+          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),+          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),+          dep_finsts = sortBy stableModuleCmp (dep_finsts d),+          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }++-- | Creates cached lookup for the 'mi_anns' field of ModIface+-- Hackily, we use "module" as the OccName for any module-level annotations+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]+mkIfaceAnnCache anns+  = \n -> lookupOccEnv env n `orElse` []+  where+    pair (IfaceAnnotation target value) =+      (case target of+          NamedTarget occn -> occn+          ModuleTarget _   -> mkVarOcc "module"+      , [value])+    -- flipping (++), so the first argument is always short+    env = mkOccEnv_C (flip (++)) (map pair anns)++{-+************************************************************************+*                                                                      *+          The ABI of an IfaceDecl+*                                                                      *+************************************************************************++Note [The ABI of an IfaceDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ABI of a declaration consists of:++   (a) the full name of the identifier (inc. module and package,+       because these are used to construct the symbol name by which+       the identifier is known externally).++   (b) the declaration itself, as exposed to clients.  That is, the+       definition of an Id is included in the fingerprint only if+       it is made available as an unfolding in the interface.++   (c) the fixity of the identifier (if it exists)+   (d) for Ids: rules+   (e) for classes: instances, fixity & rules for methods+   (f) for datatypes: instances, fixity & rules for constrs++Items (c)-(f) are not stored in the IfaceDecl, but instead appear+elsewhere in the interface file.  But they are *fingerprinted* with+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,+and fingerprinting that as part of the declaration.+-}++type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)++data IfaceDeclExtras+  = IfaceIdExtras IfaceIdExtras++  | IfaceDataExtras+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)+       [IfaceInstABI]           -- Local class and family instances of this tycon+                                -- See Note [Orphans] in InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations++  | IfaceClassExtras+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)+       [IfaceInstABI]           -- Local instances of this class *or*+                                --   of its associated data types+                                -- See Note [Orphans] in InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations+       [IfExtName]              -- Default methods. If a module+                                -- mentions a class, then it can+                                -- instantiate the class and thereby+                                -- use the default methods, so we must+                                -- include these in the fingerprint of+                                -- a class.++  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]++  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]++  | IfaceOtherDeclExtras++data IfaceIdExtras+  = IdExtras+       (Maybe Fixity)           -- Fixity of the Id (if it exists)+       [IfaceRule]              -- Rules for the Id+       [AnnPayload]             -- Annotations for the Id++-- When hashing a class or family instance, we hash only the+-- DFunId or CoAxiom, because that depends on all the+-- information about the instance.+--+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance++abiDecl :: IfaceDeclABI -> IfaceDecl+abiDecl (_, decl, _) = decl++cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`+                         getOccName (abiDecl abi2)++freeNamesDeclABI :: IfaceDeclABI -> NameSet+freeNamesDeclABI (_mod, decl, extras) =+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras++freeNamesDeclExtras :: IfaceDeclExtras -> NameSet+freeNamesDeclExtras (IfaceIdExtras id_extras)+  = freeNamesIdExtras id_extras+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)+  = unionNameSets $+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs+freeNamesDeclExtras (IfaceSynonymExtras _ _)+  = emptyNameSet+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)+  = mkNameSet insts+freeNamesDeclExtras IfaceOtherDeclExtras+  = emptyNameSet++freeNamesIdExtras :: IfaceIdExtras -> NameSet+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)++instance Outputable IfaceDeclExtras where+  ppr IfaceOtherDeclExtras       = Outputable.empty+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]+  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,+                                                ppr_id_extras_s stuff]+  ppr (IfaceClassExtras fix insts anns stuff defms) =+    vcat [ppr fix, ppr_insts insts, ppr anns,+          ppr_id_extras_s stuff, ppr defms]++ppr_insts :: [IfaceInstABI] -> SDoc+ppr_insts _ = text "<insts>"++ppr_id_extras_s :: [IfaceIdExtras] -> SDoc+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)++ppr_id_extras :: IfaceIdExtras -> SDoc+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)++-- This instance is used only to compute fingerprints+instance Binary IfaceDeclExtras where+  get _bh = panic "no get for IfaceDeclExtras"+  put_ bh (IfaceIdExtras extras) = do+   putByte bh 1; put_ bh extras+  put_ bh (IfaceDataExtras fix insts anns cons) = do+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do+   putByte bh 3+   put_ bh fix+   put_ bh insts+   put_ bh anns+   put_ bh methods+   put_ bh defms+  put_ bh (IfaceSynonymExtras fix anns) = do+   putByte bh 4; put_ bh fix; put_ bh anns+  put_ bh (IfaceFamilyExtras fix finsts anns) = do+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns+  put_ bh IfaceOtherDeclExtras = putByte bh 6++instance Binary IfaceIdExtras where+  get _bh = panic "no get for IfaceIdExtras"+  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }++declExtras :: (OccName -> Maybe Fixity)+           -> (OccName -> [AnnPayload])+           -> OccEnv [IfaceRule]+           -> OccEnv [IfaceClsInst]+           -> OccEnv [IfaceFamInst]+           -> OccEnv IfExtName          -- lookup default method names+           -> IfaceDecl+           -> IfaceDeclExtras++declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl+  = case decl of+      IfaceId{} -> IfaceIdExtras (id_extras n)+      IfaceData{ifCons=cons} ->+                     IfaceDataExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) +++                         map ifDFun         (lookupOccEnvL inst_env n))+                        (ann_fn n)+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->+                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms+          where+            insts = (map ifDFun $ (concatMap at_extras ats)+                                    ++ lookupOccEnvL inst_env n)+                           -- Include instances of the associated types+                           -- as well as instances of the class (#5147)+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]+            -- Names of all the default methods (see Note [default method Name])+            defms = [ dmName+                    | IfaceClassOp bndr _ (Just _) <- sigs+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)+                                           (ann_fn n)+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))+                        (ann_fn n)+      _other -> IfaceOtherDeclExtras+  where+        n = getOccName decl+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)+++{- Note [default method Name] (see also #15970)++The Names for the default methods aren't available in Iface syntax.++* We originally start with a DefMethInfo from the class, contain a+  Name for the default method++* We turn that into Iface syntax as a DefMethSpec which lacks a Name+  entirely. Why? Because the Name can be derived from the method name+  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface+  file.++But now we have to get the Name back, because the class declaration's+fingerprint needs to depend on it (this was the bug in #15970).  This+is done in a slightly convoluted way:++* Then, in addFingerprints we build a map that maps OccNames to Names++* We pass that map to declExtras which laboriously looks up in the map+  (using the derived occurrence name) to recover the Name we have just+  thrown away.+-}++lookupOccEnvL :: OccEnv [v] -> OccName -> [v]+lookupOccEnvL env k = lookupOccEnv env k `orElse` []++{-+-- for testing: use the md5sum command to generate fingerprints and+-- compare the results against our built-in version.+  fp' <- oldMD5 dflags bh+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')+               else return fp++oldMD5 dflags bh = do+  tmp <- newTempName dflags CurrentModule "bin"+  writeBinMem bh tmp+  tmp2 <- newTempName dflags CurrentModule "md5"+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2+  r <- system cmd+  case r of+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)+    ExitSuccess -> do+        hash_str <- readFile tmp2+        return $! readHexFingerprint hash_str+-}++----------------------+-- mkOrphMap partitions instance decls or rules into+--      (a) an OccEnv for ones that are not orphans,+--          mapping the local OccName to a list of its decls+--      (b) a list of orphan decls+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl+          -> [decl]             -- Sorted into canonical order+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;+                                --      each sublist in canonical order+              [decl])           -- Orphan decls; in canonical order+mkOrphMap get_key decls+  = foldl' go (emptyOccEnv, []) decls+  where+    go (non_orphs, orphs) d+        | NotOrphan occ <- get_key d+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)+        | otherwise = (non_orphs, d:orphs)++{-+************************************************************************+*                                                                      *+       COMPLETE Pragmas+*                                                                      *+************************************************************************+-}++mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc+++{-+************************************************************************+*                                                                      *+       Keeping track of what we've slurped, and fingerprints+*                                                                      *+************************************************************************+-}+++mkIfaceAnnotation :: Annotation -> IfaceAnnotation+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })+  = IfaceAnnotation {+        ifAnnotatedTarget = fmap nameOccName target,+        ifAnnotatedValue = payload+    }++mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical+mkIfaceExports exports+  = sortBy stableAvailCmp (map sort_subs exports)+  where+    sort_subs :: AvailInfo -> AvailInfo+    sort_subs (Avail n) = Avail n+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)+    sort_subs (AvailTC n (m:ms) fs)+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)+       -- Maintain the AvailTC Invariant++    sort_flds = sortBy (stableNameCmp `on` flSelector)++{-+Note [Original module]+~~~~~~~~~~~~~~~~~~~~~+Consider this:+        module X where { data family T }+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }+The exported Avail from Y will look like+        X.T{X.T, Y.MkT}+That is, in Y,+  - only MkT is brought into scope by the data instance;+  - but the parent (used for grouping and naming in T(..) exports) is X.T+  - and in this case we export X.T too++In the result of mkIfaceExports, the names are grouped by defining module,+so we may need to split up a single Avail into multiple ones.++Note [Internal used_names]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the used_names are External Names, but we can have Internal+Names too: see Note [Binders in Template Haskell] in Convert, and+#5362 for an example.  Such Names are always+  - Such Names are always for locally-defined things, for which we+    don't gather usage info, so we can just ignore them in ent_map+  - They are always System Names, hence the assert, just as a double check.+++************************************************************************+*                                                                      *+        Load the old interface file for this module (unless+        we have it already), and check whether it is up to date+*                                                                      *+************************************************************************+-}++data RecompileRequired+  = UpToDate+       -- ^ everything is up to date, recompilation is not required+  | MustCompile+       -- ^ The .hs file has been touched, or the .o/.hi file does not exist+  | RecompBecause String+       -- ^ 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++instance Semigroup RecompileRequired where+  UpToDate <> r = r+  mc <> _       = mc++instance Monoid RecompileRequired where+  mempty = UpToDate++recompileRequired :: RecompileRequired -> Bool+recompileRequired UpToDate = False+recompileRequired _ = True++++-- | 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+-- first element is a bool saying if we should recompile the object file+-- and the second is maybe the interface file, where Nothing means to+-- rebuild the interface file and not use the existing one.+checkOldIface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface         -- Old interface from compilation manager, if any+  -> IO (RecompileRequired, Maybe ModIface)++checkOldIface hsc_env mod_summary source_modified maybe_iface+  = do  let dflags = hsc_dflags hsc_env+        showPass dflags $+            "Checking old interface for " +++              (showPpr dflags $ ms_mod mod_summary) +++              " (use -ddump-hi-diffs for more details)"+        initIfaceCheck (text "checkOldIface") hsc_env $+            check_old_iface hsc_env mod_summary source_modified maybe_iface++check_old_iface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface+  -> IfG (RecompileRequired, Maybe ModIface)++check_old_iface hsc_env mod_summary src_modified maybe_iface+  = let dflags = hsc_dflags hsc_env+        getIface =+            case maybe_iface of+                Just _  -> do+                    traceIf (text "We already have the old interface for" <+>+                      ppr (ms_mod mod_summary))+                    return maybe_iface+                Nothing -> loadIface++        loadIface = do+             let iface_path = msHiFilePath mod_summary+             read_result <- readIface (ms_mod mod_summary) iface_path+             case read_result of+                 Failed err -> do+                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)+                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)+                     return Nothing+                 Succeeded iface -> do+                     traceIf (text "Read the interface file" <+> text iface_path)+                     return $ Just iface++        src_changed+            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True+            | SourceModified <- src_modified = True+            | otherwise = False+    in do+        when src_changed $+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")++        case src_changed of+            -- If the source has changed and we're in interactive mode,+            -- avoid reading an interface; just return the one we might+            -- have been supplied with.+            True | not (isObjectTarget $ hscTarget dflags) ->+                return (MustCompile, maybe_iface)++            -- Try and read the old interface for the current module+            -- from the .hi file left from the last time we compiled it+            True -> do+                maybe_iface' <- getIface+                return (MustCompile, maybe_iface')++            False -> do+                maybe_iface' <- getIface+                case maybe_iface' of+                    -- We can't retrieve the iface+                    Nothing    -> return (MustCompile, Nothing)++                    -- We have got the old iface; check its versions+                    -- even in the SourceUnmodifiedAndStable case we+                    -- should check versions because some packages+                    -- might have changed or gone away.+                    Just iface -> checkVersions hsc_env mod_summary iface++-- | Check if a module is still the same 'version'.+--+-- This function is called in the recompilation checker after we have+-- determined that the module M being checked hasn't had any changes+-- to its source file since we last compiled M. So at this point in general+-- two things may have changed that mean we should recompile M:+--   * The interface export by a dependency of M has changed.+--   * The compiler flags specified this time for M have changed+--     in a manner that is significant for recompilation.+-- We return not just if we should recompile the object file but also+-- if we should rebuild the interface file.+checkVersions :: HscEnv+              -> ModSummary+              -> ModIface       -- Old interface+              -> IfG (RecompileRequired, Maybe ModIface)+checkVersions hsc_env mod_summary iface+  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>+                        ppr (mi_module iface) <> colon)++       -- readIface will have verified that the InstalledUnitId matches,+       -- but we ALSO must make sure the instantiation matches up.  See+       -- test case bkpcabal04!+       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)+            then return (RecompBecause "-this-unit-id changed", Nothing) else do {+       ; recomp <- checkFlagHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkOptimHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHpcHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkMergedSignatures mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHsig mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHie 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 {+       ; recomp <- checkPlugins hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+++       -- Source code unchanged and no errors yet... carry on+       --+       -- First put the dependent-module info, read from the old+       -- interface, into the envt, so that when we look for+       -- interfaces we look for the right one (.hi or .hi-boot)+       --+       -- It's just temporary because either the usage check will succeed+       -- (in which case we are done with this module) or it'll fail (in which+       -- case we'll compile the module from scratch anyhow).+       --+       -- We do this regardless of compilation mode, although in --make mode+       -- all the dependent modules should be in the HPT already, so it's+       -- quite redundant+       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }+       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]+       ; return (recomp, Just iface)+    }}}}}}}}}}+  where+    this_pkg = thisPackage (hsc_dflags hsc_env)+    -- This is a bit of a hack really+    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)+    mod_deps = mkModDeps (dep_mods (mi_deps iface))++-- | Check if any plugins are requesting recompilation+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired+checkPlugins hsc iface = liftIO $ do+  new_fingerprint <- fingerprintPlugins hsc+  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)+  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))+  return $+    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr++fingerprintPlugins :: HscEnv -> IO Fingerprint+fingerprintPlugins hsc_env = do+  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)++fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint+fingerprintPlugins' plugins = do+  res <- mconcat <$> mapM pluginRecompile' plugins+  return $ case res of+      NoForceRecompile ->  fingerprintString "NoForceRecompile"+      ForceRecompile   -> fingerprintString "ForceRecompile"+      -- is the chance of collision worth worrying about?+      -- An alternative is to fingerprintFingerprints [fingerprintString+      -- "maybeRecompile", fp]+      (MaybeRecompile fp) -> fp+++pluginRecompileToRecompileRequired+    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired+pluginRecompileToRecompileRequired old_fp new_fp pr+  | old_fp == new_fp =+    case pr of+      NoForceRecompile  -> UpToDate++      -- we already checked the fingerprint above so a mismatch is not possible+      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.+      MaybeRecompile _  -> UpToDate++      -- 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"++  | old_fp `elem` magic_fingerprints ||+    new_fp `elem` magic_fingerprints+    -- The fingerprints do not match either the old or new one is a magic+    -- fingerprint. This happens when non-pure plugins are added for the first+    -- time or when we go from one recompilation strategy to another: (force ->+    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)+    --+    -- For example when we go from 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"++  | 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++      _                -> RecompBecause reason++ where+   magic_fingerprints =+       [ fingerprintString "NoForceRecompile"+       , fingerprintString "ForceRecompile"+       ]+++-- | Check if an hsig file needs recompilation because its+-- implementing module has changed.+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired+checkHsig mod_summary iface = do+    dflags <- getDynFlags+    let outer_mod = ms_mod mod_summary+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    case inner_mod == mi_semantic_module iface of+        True -> up_to_date (text "implementing module unchanged")+        False -> return (RecompBecause "implementing module changed")++-- | Check if @.hie@ file is out of date or missing.+checkHie :: ModSummary -> IfG RecompileRequired+checkHie mod_summary = do+    dflags <- getDynFlags+    let hie_date_opt = ms_hie_date mod_summary+        hs_date = ms_hs_date mod_summary+    pure $ case gopt Opt_WriteHie dflags of+               False -> UpToDate+               True -> case hie_date_opt of+                           Nothing -> RecompBecause "HIE file is missing"+                           Just hie_date+                               | hie_date < hs_date+                               -> RecompBecause "HIE file is out of date"+                               | otherwise+                               -> UpToDate++-- | Check the flags haven't changed+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkFlagHash hsc_env iface = do+    let old_hash = mi_flag_hash (mi_final_exts iface)+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)+                                             (mi_module iface)+                                             putNameLiterally+    case old_hash == new_hash of+        True  -> up_to_date (text "Module flags unchanged")+        False -> out_of_date_hash "flags changed"+                     (text "  Module flags have changed")+                     old_hash new_hash++-- | Check the optimisation flags haven't changed+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkOptimHash hsc_env iface = do+    let old_hash = mi_opt_hash (mi_final_exts iface)+    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date (text "Optimisation flags unchanged")+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)+         -> up_to_date (text "Optimisation flags changed; ignoring")+       | otherwise+         -> out_of_date_hash "Optimisation flags changed"+                     (text "  Optimisation flags have changed")+                     old_hash new_hash++-- | Check the HPC flags haven't changed+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkHpcHash hsc_env iface = do+    let old_hash = mi_hpc_hash (mi_final_exts iface)+    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date (text "HPC flags unchanged")+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)+         -> up_to_date (text "HPC flags changed; ignoring")+       | otherwise+         -> out_of_date_hash "HPC flags changed"+                     (text "  HPC flags have changed")+                     old_hash new_hash++-- Check that the set of signatures we are merging in match.+-- If the -unit-id flags change, this can change too.+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired+checkMergedSignatures mod_summary iface = do+    dflags <- getDynFlags+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]+        new_merged = case Map.lookup (ms_mod_name mod_summary)+                                     (requirementContext (pkgState dflags)) of+                        Nothing -> []+                        Just r -> sort $ map (indefModuleToModule dflags) r+    if old_merged == new_merged+        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return (RecompBecause "signatures to merge in changed")++-- If the direct imports of this module are resolved to targets that+-- are not among the dependencies of the previous interface file,+-- then we definitely need to recompile.  This catches cases like+--   - an exposed package has been upgraded+--   - we are compiling with different package flags+--   - a home module that was shadowing a package module has been removed+--   - a new home module has been added that shadows a package module+-- See bug #1372.+--+-- In addition, we also check if the union of dependencies of the imported+-- modules has any difference to the previous set of dependencies. We would need+-- to recompile in that case also since the `mi_deps` field of ModIface needs+-- to be updated to match that information. This is one of the invariants+-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).+-- See bug #16511.+--+-- Returns (RecompBecause <textual reason>) if recompilation is required.+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired+checkDependencies hsc_env summary iface+ = do+   checkList $+     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))+     , do+         (recomp, mnames_seen) <- runUntilRecompRequired $ map+           checkForNewHomeDependency+           (ms_home_imps summary)+         case recomp of+           UpToDate -> do+             let+               seen_home_deps = Set.unions $ map Set.fromList mnames_seen+             checkIfAllOldHomeDependenciesAreSeen seen_home_deps+           _ -> return recomp]+ where+   prev_dep_mods = dep_mods (mi_deps iface)+   prev_dep_plgn = dep_plgins (mi_deps iface)+   prev_dep_pkgs = dep_pkgs (mi_deps iface)++   this_pkg = thisPackage (hsc_dflags hsc_env)++   dep_missing (mb_pkg, L _ mod) = do+     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)+     let reason = moduleNameString mod ++ " changed"+     case find_res of+        Found _ mod+          | pkg == this_pkg+           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+          | otherwise+           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " is from package " <> quotes (ppr pkg) <>+                           text ", which is not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+           where pkg = moduleUnitId mod+        _otherwise  -> return (RecompBecause reason)++   old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods+   isOldHomeDeps = flip Set.member old_deps+   checkForNewHomeDependency (L _ mname) = do+     let+       mod = mkModule this_pkg mname+       str_mname = moduleNameString mname+       reason = str_mname ++ " changed"+     -- We only want to look at home modules to check if any new home dependency+     -- pops in and thus here, skip modules that are not home. Checking+     -- membership in old home dependencies suffice because the `dep_missing`+     -- check already verified that all imported home modules are present there.+     if not (isOldHomeDeps mname)+       then return (UpToDate, [])+       else do+         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do+           let mnames = mname:(map fst $ filter (not . snd) $+                 dep_mods $ mi_deps imported_iface)+           case find (not . isOldHomeDeps) mnames of+             Nothing -> return (UpToDate, mnames)+             Just new_dep_mname -> do+               traceHiDiffs $+                 text "imported home module " <> quotes (ppr mod) <>+                 text " has a new dependency " <> quotes (ppr new_dep_mname)+               return (RecompBecause reason, [])+         return $ fromMaybe (MustCompile, []) mb_result++   -- Performs all recompilation checks in the list until a check that yields+   -- recompile required is encountered. Returns the list of the results of+   -- all UpToDate checks.+   runUntilRecompRequired []             = return (UpToDate, [])+   runUntilRecompRequired (check:checks) = do+     (recompile, value) <- check+     if recompileRequired recompile+       then return (recompile, [])+       else do+         (recomp, values) <- runUntilRecompRequired checks+         return (recomp, value:values)++   checkIfAllOldHomeDependenciesAreSeen seen_deps = do+     let unseen_old_deps = Set.difference+          old_deps+          seen_deps+     if not (null unseen_old_deps)+       then do+         let missing_dep = Set.elemAt 0 unseen_old_deps+         traceHiDiffs $+           text "missing old home dependency " <> quotes (ppr missing_dep)+         return $ RecompBecause "missing old dependency"+       else return UpToDate++needInterface :: Module -> (ModIface -> IfG RecompileRequired)+             -> IfG RecompileRequired+needInterface mod continue+  = do+      mb_recomp <- getFromModIface+        "need version info for"+        mod+        continue+      case mb_recomp of+        Nothing -> return MustCompile+        Just recomp -> return recomp++getFromModIface :: String -> Module -> (ModIface -> IfG a)+              -> IfG (Maybe a)+getFromModIface doc_msg mod getter+  = do  -- Load the imported interface if possible+    let doc_str = sep [text doc_msg, ppr mod]+    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)++    mb_iface <- loadInterface doc_str mod ImportBySystem+        -- Load the interface, but don't complain on failure;+        -- Instead, get an Either back which we can test++    case mb_iface of+      Failed _ -> do+        traceHiDiffs (sep [text "Couldn't load interface for module",+                           ppr mod])+        return Nothing+                  -- Couldn't find or parse a module mentioned in the+                  -- old interface file.  Don't complain: it might+                  -- just be that the current module doesn't need that+                  -- import and it's been deleted+      Succeeded iface -> Just <$> getter iface++-- | Given the usage information extracted from the old+-- M.hi file for the module being compiled, figure out+-- whether M needs to be recompiled.+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired+checkModUsage _this_pkg UsagePackageModule{+                                usg_mod = mod,+                                usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed"+    checkModuleFingerprint 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+        -- recompile.  This is safe but may entail more recompilation when+        -- a dependent package has changed.++checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))++checkModUsage this_pkg UsageHomeModule{+                                usg_mod_name = mod_name,+                                usg_mod_hash = old_mod_hash,+                                usg_exports = maybe_old_export_hash,+                                usg_entities = old_decl_hash }+  = do+    let mod = mkModule this_pkg mod_name+    needInterface mod $ \iface -> do++    let+        new_mod_hash    = mi_mod_hash (mi_final_exts iface)+        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"++        -- CHECK MODULE+    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash+    if not (recompileRequired recompile)+      then return UpToDate+      else do++        -- CHECK EXPORT LIST+        checkMaybeHash reason maybe_old_export_hash new_export_hash+            (text "  Export list changed") $ do++        -- CHECK ITEMS ONE BY ONE+        recompile <- checkList [ checkEntityUsage reason new_decl_hash u+                               | u <- old_decl_hash]+        if recompileRequired recompile+          then return recompile     -- This one failed, so just bail out now+          else up_to_date (text "  Great!  The bits I use are up to date")+++checkModUsage _this_pkg UsageFile{ usg_file_path = file,+                                   usg_file_hash = old_hash } =+  liftIO $+    handleIO handle $ do+      new_hash <- getFileHash file+      if (old_hash /= new_hash)+         then return recomp+         else return UpToDate+ where+   recomp = RecompBecause (file ++ " changed")+   handle =+#if defined(DEBUG)+       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+#else+       \_ -> return recomp -- if we can't find the file, just recompile, don't fail+#endif++------------------------+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint+                       -> IfG RecompileRequired+checkModuleFingerprint reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date (text "Module fingerprint unchanged")++  | otherwise+  = out_of_date_hash reason (text "  Module fingerprint has changed")+                     old_mod_hash new_mod_hash++------------------------+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc+               -> IfG RecompileRequired -> IfG RecompileRequired+checkMaybeHash reason maybe_old_hash new_hash doc continue+  | Just hash <- maybe_old_hash, hash /= new_hash+  = out_of_date_hash reason doc hash new_hash+  | otherwise+  = continue++------------------------+checkEntityUsage :: String+                 -> (OccName -> Maybe (OccName, Fingerprint))+                 -> (OccName, Fingerprint)+                 -> IfG RecompileRequired+checkEntityUsage reason new_hash (name,old_hash)+  = case new_hash name of++        Nothing       ->        -- We used it before, but it ain't there now+                          out_of_date reason (sep [text "No longer exported:", ppr name])++        Just (_, new_hash)      -- It's there, but is it up to date?+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+                                       return UpToDate+          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)+                                                     old_hash new_hash++up_to_date :: SDoc -> IfG RecompileRequired+up_to_date  msg = traceHiDiffs msg >> return UpToDate++out_of_date :: String -> SDoc -> IfG RecompileRequired+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)++out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired+out_of_date_hash reason msg old_hash new_hash+  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])++----------------------+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired+-- This helper is used in two places+checkList []             = return UpToDate+checkList (check:checks) = do recompile <- check+                              if recompileRequired recompile+                                then return recompile+                                else checkList checks++{-+************************************************************************+*                                                                      *+                Converting things to their Iface equivalents+*                                                                      *+************************************************************************+-}++tyThingToIfaceDecl :: TyThing -> IfaceDecl+tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)+tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax+tyThingToIfaceDecl (AConLike cl)  = case cl of+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only+    PatSynCon ps   -> patSynToIfaceDecl ps++--------------------------+idToIfaceDecl :: Id -> IfaceDecl+-- The Id is already tidied, so that locally-bound names+-- (lambdas, for-alls) already have non-clashing OccNames+-- We can't tidy it here, locally, because it may have+-- free variables in its type or IdInfo+idToIfaceDecl id+  = IfaceId { ifName      = getName id,+              ifType      = toIfaceType (idType id),+              ifIdDetails = toIfaceIdDetails (idDetails id),+              ifIdInfo    = toIfaceIdInfo (idInfo id) }++--------------------------+dataConToIfaceDecl :: DataCon -> IfaceDecl+dataConToIfaceDecl dataCon+  = IfaceId { ifName      = getName dataCon,+              ifType      = toIfaceType (dataConUserType dataCon),+              ifIdDetails = IfVanillaId,+              ifIdInfo    = NoInfo }++--------------------------+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl+-- We *do* tidy Axioms, because they are not (and cannot+-- conveniently be) built in tidy form+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches+                               , co_ax_role = role })+ = IfaceAxiom { ifName       = getName ax+              , ifTyCon      = toIfaceTyCon tycon+              , ifRole       = role+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon+                                     (map coAxBranchLHS branch_list))+                                   branch_list }+ where+   branch_list = fromBranches branches++-- 2nd parameter is the list of branch LHSs, in case of a closed type family,+-- for conversion from incompatible branches to incompatible indices.+-- For an open type family the list should be empty.+-- See Note [Storing compatibility] in CoAxiom+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch tc lhs_s+                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                    , cab_eta_tvs = eta_tvs+                                    , cab_lhs = lhs, cab_roles = roles+                                    , cab_rhs = rhs, cab_incomps = incomps })++  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs+                  , ifaxbCoVars  = map toIfaceIdBndr cvs+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs+                  , ifaxbLHS     = toIfaceTcArgs tc lhs+                  , ifaxbRoles   = roles+                  , ifaxbRHS     = toIfaceType rhs+                  , ifaxbIncomps = iface_incomps }+  where+    iface_incomps = map (expectJust "iface_incomps"+                        . flip findIndex lhs_s+                        . eqTypes+                        . coAxBranchLHS) incomps++-----------------+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)+-- We *do* tidy TyCons, because they are not (and cannot+-- conveniently be) built in tidy form+-- The returned TidyEnv is the one after tidying the tyConTyVars+tyConToIfaceDecl env tycon+  | Just clas <- tyConClass_maybe tycon+  = classToIfaceDecl env clas++  | Just syn_rhs <- synTyConRhs_maybe tycon+  = ( tc_env1+    , IfaceSynonym { ifName    = getName tycon,+                     ifRoles   = tyConRoles tycon,+                     ifSynRhs  = if_syn_type syn_rhs,+                     ifBinders = if_binders,+                     ifResKind = if_res_kind+                   })++  | Just fam_flav <- famTyConFlav_maybe tycon+  = ( tc_env1+    , IfaceFamily { ifName    = getName tycon,+                    ifResVar  = if_res_var,+                    ifFamFlav = to_if_fam_flav fam_flav,+                    ifBinders = if_binders,+                    ifResKind = if_res_kind,+                    ifFamInj  = tyConInjectivityInfo tycon+                  })++  | isAlgTyCon tycon+  = ( tc_env1+    , IfaceData { ifName    = getName tycon,+                  ifBinders = if_binders,+                  ifResKind = if_res_kind,+                  ifCType   = tyConCType tycon,+                  ifRoles   = tyConRoles tycon,+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),+                  ifCons    = ifaceConDecls (algTyConRhs tycon),+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,+                  ifParent  = parent })++  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon+  -- We only convert these TyCons to IfaceTyCons when we are+  -- just about to pretty-print them, not because we are going+  -- to put them into interface files+  = ( env+    , IfaceData { ifName       = getName tycon,+                  ifBinders    = if_binders,+                  ifResKind    = if_res_kind,+                  ifCType      = Nothing,+                  ifRoles      = tyConRoles tycon,+                  ifCtxt       = [],+                  ifCons       = IfDataTyCon [],+                  ifGadtSyntax = False,+                  ifParent     = IfNoParent })+  where+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause+    -- an error.+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)+    tc_tyvars      = binderVars tc_binders+    if_binders     = toIfaceTyCoVarBinders tc_binders+                     -- No tidying of the binders; they are already tidy+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)+    if_syn_type ty = tidyToIfaceType tc_env1 ty+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon++    parent = case tyConFamInstSig_maybe tycon of+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)+                                                   (toIfaceTyCon tc)+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)+               Nothing           -> IfNoParent++    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))+      where defs = fromBranches $ coAxiomBranches ax+            lhss = map coAxBranchLHS defs+            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs+            axn  = coAxiomName ax++    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)+    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon+        -- The AbstractTyCon case happens when a TyCon has been trimmed+        -- during tidying.+        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver+        -- for GHCi, when browsing a module, in which case the+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.+        -- (Tuple declarations are not serialised into interface files.)++    ifaceConDecl data_con+        = IfCon   { ifConName    = dataConName data_con,+                    ifConInfix   = dataConIsInfix data_con,+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),+                    ifConExTCvs  = map toIfaceBndr ex_tvs',+                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,+                    ifConFields  = dataConFieldLabels data_con,+                    ifConStricts = map (toIfaceBang con_env2)+                                       (dataConImplBangs data_con),+                    ifConSrcStricts = map toIfaceSrcBang+                                          (dataConSrcBangs data_con)}+        where+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)+            = dataConFullSig data_con+          user_bndrs = dataConUserTyVarBinders data_con++          -- Tidy the univ_tvs of the data constructor to be identical+          -- to the tyConTyVars of the type constructor.  This means+          -- (a) we don't need to redundantly put them into the interface file+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,+          --     we know that the type variables will line up+          -- The latter (b) is important because we pretty-print type constructors+          -- by converting to Iface syntax and pretty-printing that+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))+                     -- A bit grimy, perhaps, but it's simple!++          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs+          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)++          -- By this point, we have tidied every universal and existential+          -- tyvar. Because of the dcUserTyCoVarBinders invariant+          -- (see Note [DataCon user type variable binders]), *every*+          -- user-written tyvar must be contained in the substitution that+          -- tidying produced. Therefore, tidying the user-written tyvars is a+          -- simple matter of looking up each variable in the substitution,+          -- which tidyTyCoVarOcc accomplishes.+          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder+          tidyUserTyCoVarBinder env (Bndr tv vis) =+            Bndr (tidyTyCoVarOcc env tv) vis++classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)+classToIfaceDecl env clas+  = ( env1+    , IfaceClass { ifName   = getName tycon,+                   ifRoles  = tyConRoles (classTyCon clas),+                   ifBinders = toIfaceTyCoVarBinders tc_binders,+                   ifBody   = body,+                   ifFDs    = map toIfaceFD clas_fds })+  where+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)+      = classExtraBigSig clas+    tycon = classTyCon clas++    body | isAbstractTyCon tycon = IfAbstractClass+         | otherwise+         = IfConcreteClass {+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,+                ifATs    = map toIfaceAT clas_ats,+                ifSigs   = map toIfaceClassOp op_stuff,+                ifMinDef = fmap getOccFS (classMinimalDef clas)+            }++    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)++    toIfaceAT :: ClassATItem -> IfaceAT+    toIfaceAT (ATI tc def)+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)+      where+        (env2, if_decl) = tyConToIfaceDecl env1 tc++    toIfaceClassOp (sel_id, def_meth)+        = ASSERT( sel_tyvars == binderVars tc_binders )+          IfaceClassOp (getName sel_id)+                       (tidyToIfaceType env1 op_ty)+                       (fmap toDmSpec def_meth)+        where+                -- Be careful when splitting the type, because of things+                -- like         class Foo a where+                --                op :: (?x :: String) => a -> a+                -- and          class Baz a where+                --                op :: (Ord a) => a -> a+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)+          op_ty                = funResultTy rho_ty++    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType+    toDmSpec (_, VanillaDM)       = VanillaDM+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)++    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1+                             ,map (tidyTyVar env1) tvs2)++--------------------------++tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)+-- If the type variable "binder" is in scope, don't re-bind it+-- In a class decl, for example, the ATD binders mention+-- (amd must mention) the class tyvars+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)+ = case lookupVarEnv subst tv of+     Just tv' -> (env,  Bndr tv' vis)+     Nothing  -> tidyTyCoVarBinder env tvb++tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])+tidyTyConBinders = mapAccumL tidyTyConBinder++tidyTyVar :: TidyEnv -> TyVar -> FastString+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)++--------------------------+instanceToIfaceInst :: ClsInst -> IfaceClsInst+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag+                             , is_cls_nm = cls_name, is_cls = cls+                             , is_tcs = mb_tcs+                             , is_orphan = orph })+  = ASSERT( cls_name == className cls )+    IfaceClsInst { ifDFun    = dfun_name,+                ifOFlag   = oflag,+                ifInstCls = cls_name,+                ifInstTys = map do_rough mb_tcs,+                ifInstOrph = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    dfun_name = idName dfun_id+++--------------------------+famInstToIfaceFamInst :: FamInst -> IfaceFamInst+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,+                                 fi_fam      = fam,+                                 fi_tcs      = roughs })+  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom+                 , ifFamInstFam      = fam+                 , ifFamInstTys      = map do_rough roughs+                 , ifFamInstOrph     = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    fam_decl = tyConName $ coAxiomTyCon axiom+    mod = ASSERT( isExternalName (coAxiomName axiom) )+          nameModule (coAxiomName axiom)+    is_local name = nameIsLocalOrFrom mod name++    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)++    orph | is_local fam_decl+         = NotOrphan (nameOccName fam_decl)+         | otherwise+         = chooseOrphanAnchor lhs_names++--------------------------+coreRuleToIfaceRule :: CoreRule -> IfaceRule+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})+  = pprTrace "toHsRule: builtin" (ppr fn) $+    bogusIfaceRule fn++coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,+                            ru_act = act, ru_bndrs = bndrs,+                            ru_args = args, ru_rhs = rhs,+                            ru_orphan = orph, ru_auto = auto })+  = IfaceRule { ifRuleName  = name, ifActivation = act,+                ifRuleBndrs = map toIfaceBndr bndrs,+                ifRuleHead  = fn,+                ifRuleArgs  = map do_arg args,+                ifRuleRhs   = toIfaceExpr rhs,+                ifRuleAuto  = auto,+                ifRuleOrph  = orph }+  where+        -- For type args we must remove synonyms from the outermost+        -- level.  Reason: so that when we read it back in we'll+        -- construct the same ru_rough field as we have right now;+        -- see tcIfaceRule+    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))+    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)+    do_arg arg           = toIfaceExpr arg++bogusIfaceRule :: Name -> IfaceRule+bogusIfaceRule id_name+  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,+        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,+        ifRuleAuto = True }
+ compiler/GHC/IfaceToCore.hs view
@@ -0,0 +1,1827 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Type checking of type signatures in interface files+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.IfaceToCore (+        tcLookupImported_maybe,+        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,+        typecheckIfacesForMerging,+        typecheckIfaceForInstantiate,+        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,+        tcIfaceAnnotations, tcIfaceCompleteSigs,+        tcIfaceExpr,    -- Desired by HERMIT (#7683)+        tcIfaceGlobal+ ) where++#include "HsVersions.h"++import GhcPrelude++import TcTypeNats(typeNatCoAxiomRules)+import GHC.Iface.Syntax+import GHC.Iface.Load+import GHC.Iface.Env+import BuildTyCl+import TcRnMonad+import TcType+import Type+import Coercion+import CoAxiom+import TyCoRep    -- needs to build types & coercions in a knot+import TyCoSubst ( substTyCoVars )+import HscTypes+import Annotations+import InstEnv+import FamInstEnv+import CoreSyn+import CoreUtils+import CoreUnfold+import CoreLint+import MkCore+import Id+import MkId+import IdInfo+import Class+import TyCon+import ConLike+import DataCon+import PrelNames+import TysWiredIn+import Literal+import Var+import VarSet+import Name+import NameEnv+import NameSet+import OccurAnal        ( occurAnalyseExpr )+import Demand+import Module+import UniqFM+import UniqSupply+import Outputable+import Maybes+import SrcLoc+import DynFlags+import Util+import FastString+import BasicTypes hiding ( SuccessFlag(..) )+import ListSetOps+import GHC.Fingerprint+import qualified BooleanFormula as BF++import Control.Monad+import qualified Data.Map as Map++{-+This module takes++        IfaceDecl -> TyThing+        IfaceType -> Type+        etc++An IfaceDecl is populated with RdrNames, and these are not renamed to+Names before typechecking, because there should be no scope errors etc.++        -- For (b) consider: f = \$(...h....)+        -- where h is imported, and calls f via an hi-boot file.+        -- This is bad!  But it is not seen as a staging error, because h+        -- is indeed imported.  We don't want the type-checker to black-hole+        -- when simplifying and compiling the splice!+        --+        -- Simple solution: discard any unfolding that mentions a variable+        -- bound in this module (and hence not yet processed).+        -- The discarding happens when forkM finds a type error.+++************************************************************************+*                                                                      *+                Type-checking a complete interface+*                                                                      *+************************************************************************++Suppose we discover we don't need to recompile.  Then we must type+check the old interface file.  This is a bit different to the+incremental type checking we do as we suck in interface files.  Instead+we do things similarly as when we are typechecking source decls: we+bring into scope the type envt for the interface all at once, using a+knot.  Remember, the decls aren't necessarily in dependency order --+and even if they were, the type decls might be mutually recursive.++Note [Knot-tying typecheckIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are typechecking an interface A.hi, and we come across+a Name for another entity defined in A.hi.  How do we get the+'TyCon', in this case?  There are three cases:++    1) tcHiBootIface in GHC.IfaceToCore: We're typechecking an+    hi-boot file in preparation of checking if the hs file we're+    building is compatible.  In this case, we want all of the+    internal TyCons to MATCH the ones that we just constructed+    during typechecking: the knot is thus tied through if_rec_types.++    2) retypecheckLoop in GhcMake: We are retypechecking a+    mutually recursive cluster of hi files, in order to ensure+    that all of the references refer to each other correctly.+    In this case, the knot is tied through the HPT passed in,+    which contains all of the interfaces we are in the process+    of typechecking.++    3) genModDetails in HscMain: We are typechecking an+    old interface to generate the ModDetails.  In this case,+    we do the same thing as (2) and pass in an HPT with+    the HomeModInfo being generated to tie knots.++The upshot is that the CLIENT of this function is responsible+for making sure that the knot is tied correctly.  If you don't,+then you'll get a message saying that we couldn't load the+declaration you wanted.++BTW, in one-shot mode we never call typecheckIface; instead,+loadInterface handles type-checking interface.  In that case,+knots are tied through the EPS.  No problem!+-}++-- Clients of this function be careful, see Note [Knot-tying typecheckIface]+typecheckIface :: ModIface      -- Get the decls from here+               -> IfG ModDetails+typecheckIface iface+  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do+        {       -- Get the right set of decls and rules.  If we are compiling without -O+                -- we discard pragmas before typechecking, so that we don't "see"+                -- information that we shouldn't.  From a versioning point of view+                -- It's not actually *wrong* to do so, but in fact GHCi is unable+                -- to handle unboxed tuples, so it must not see unfoldings.+          ignore_prags <- goptM Opt_IgnoreInterfacePragmas++                -- Typecheck the decls.  This is done lazily, so that the knot-tying+                -- within this single module works out right.  It's the callers+                -- job to make sure the knot is tied.+        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)+        ; let type_env = mkNameEnv names_w_things++                -- Now do those rules, instances and annotations+        ; insts     <- mapM tcIfaceInst (mi_insts iface)+        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        ; anns      <- tcIfaceAnnotations (mi_anns iface)++                -- Exports+        ; exports <- ifaceExportNames (mi_exports iface)++                -- Complete Sigs+        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)++                -- Finished+        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),+                         -- Careful! If we tug on the TyThing thunks too early+                         -- we'll infinite loop with hs-boot.  See #10083 for+                         -- an example where this would cause non-termination.+                         text "Type envt:" <+> ppr (map fst names_w_things)])+        ; return $ ModDetails { md_types     = type_env+                              , md_insts     = insts+                              , md_fam_insts = fam_insts+                              , md_rules     = rules+                              , md_anns      = anns+                              , md_exports   = exports+                              , md_complete_sigs = complete_sigs+                              }+    }++{-+************************************************************************+*                                                                      *+                Typechecking for merging+*                                                                      *+************************************************************************+-}++-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)+isAbstractIfaceDecl :: IfaceDecl -> Bool+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True+isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True+isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True+isAbstractIfaceDecl _ = False++ifMaybeRoles :: IfaceDecl -> Maybe [Role]+ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs+ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs+ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs+ifMaybeRoles _ = Nothing++-- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If+-- both are non-abstract we pick one arbitrarily (and check for consistency+-- later.)+mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl+mergeIfaceDecl d1 d2+    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1+    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2+    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1+    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2+    = let ops = nameEnvElts $+                  plusNameEnv_C mergeIfaceClassOp+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])+      in d1 { ifBody = (ifBody d1) {+                ifSigs  = ops,+                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]+                }+            } `withRolesFrom` d2+    -- It doesn't matter; we'll check for consistency later when+    -- we merge, see 'mergeSignatures'+    | otherwise              = d1 `withRolesFrom` d2++-- Note [Role merging]+-- ~~~~~~~~~~~~~~~~~~~+-- First, why might it be necessary to do a non-trivial role+-- merge?  It may rescue a merge that might otherwise fail:+--+--      signature A where+--          type role T nominal representational+--          data T a b+--+--      signature A where+--          type role T representational nominal+--          data T a b+--+-- A module that defines T as representational in both arguments+-- would successfully fill both signatures, so it would be better+-- if we merged the roles of these types in some nontrivial+-- way.+--+-- However, we have to be very careful about how we go about+-- doing this, because role subtyping is *conditional* on+-- the supertype being NOT representationally injective, e.g.,+-- if we have instead:+--+--      signature A where+--          type role T nominal representational+--          data T a b = T a b+--+--      signature A where+--          type role T representational nominal+--          data T a b = T a b+--+-- Should we merge the definitions of T so that the roles are R/R (or N/N)?+-- Absolutely not: neither resulting type is a subtype of the original+-- types (see Note [Role subtyping]), because data is not representationally+-- injective.+--+-- Thus, merging only occurs when BOTH TyCons in question are+-- representationally injective.  If they're not, no merge.++withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl+d1 `withRolesFrom` d2+    | Just roles1 <- ifMaybeRoles d1+    , Just roles2 <- ifMaybeRoles d2+    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)+    = d1 { ifRoles = mergeRoles roles1 roles2 }+    | otherwise = d1+  where+    mergeRoles roles1 roles2 = zipWith max roles1 roles2++isRepInjectiveIfaceDecl :: IfaceDecl -> Bool+isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True+isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True+isRepInjectiveIfaceDecl _ = False++mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp+mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1+mergeIfaceClassOp _ op2 = op2++-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.+mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl+mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl++-- | This is a very interesting function.  Like typecheckIface, we want+-- to type check an interface file into a ModDetails.  However, the use-case+-- for these ModDetails is different: we want to compare all of the+-- ModDetails to ensure they define compatible declarations, and then+-- merge them together.  So in particular, we have to take a different+-- strategy for knot-tying: we first speculatively merge the declarations+-- to get the "base" truth for what we believe the types will be+-- (this is "type computation.")  Then we read everything in relative+-- to this truth and check for compatibility.+--+-- During the merge process, we may need to nondeterministically+-- pick a particular declaration to use, if multiple signatures define+-- the declaration ('mergeIfaceDecl').  If, for all choices, there+-- are no type synonym cycles in the resulting merged graph, then+-- we can show that our choice cannot matter. Consider the+-- set of entities which the declarations depend on: by assumption+-- of acyclicity, we can assume that these have already been shown to be equal+-- to each other (otherwise merging will fail).  Then it must+-- be the case that all candidate declarations here are type-equal+-- (the choice doesn't matter) or there is an inequality (in which+-- case merging will fail.)+--+-- Unfortunately, the choice can matter if there is a cycle.  Consider the+-- following merge:+--+--      signature H where { type A = C;  type B = A; data C      }+--      signature H where { type A = (); data B;     type C = B  }+--+-- If we pick @type A = C@ as our representative, there will be+-- a cycle and merging will fail. But if we pick @type A = ()@ as+-- our representative, no cycle occurs, and we instead conclude+-- that all of the types are unit.  So it seems that we either+-- (a) need a stronger acyclicity check which considers *all*+-- possible choices from a merge, or (b) we must find a selection+-- of declarations which is acyclic, and show that this is always+-- the "best" choice we could have made (ezyang conjectures this+-- is the case but does not have a proof).  For now this is+-- not implemented.+--+-- It's worth noting that at the moment, a data constructor and a+-- type synonym are never compatible.  Consider:+--+--      signature H where { type Int=C;         type B = Int; data C = Int}+--      signature H where { export Prelude.Int; data B;       type C = B; }+--+-- This will be rejected, because the reexported Int in the second+-- signature (a proper data type) is never considered equal to a+-- type synonym.  Perhaps this should be relaxed, where a type synonym+-- in a signature is considered implemented by a data type declaration+-- which matches the reference of the type synonym.+typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])+typecheckIfacesForMerging mod ifaces tc_env_var =+  -- cannot be boot (False)+  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas+    -- Build the initial environment+    -- NB: Don't include dfuns here, because we don't want to+    -- serialize them out.  See Note [rnIfaceNeverExported] in GHC.Iface.Rename+    -- NB: But coercions are OK, because they will have the right OccName.+    let mk_decl_env decls+            = mkOccEnv [ (getOccName decl, decl)+                       | decl <- decls+                       , case decl of+                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns+                            _ -> True ]+        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces+                        :: [OccEnv IfaceDecl]+        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs+                        ::  OccEnv IfaceDecl+    -- TODO: change loadDecls to accept w/o Fingerprint+    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))+                                                  (occEnvElts decl_env))+    let global_type_env = mkNameEnv names_w_things+    writeMutVar tc_env_var global_type_env++    -- OK, now typecheck each ModIface using this environment+    details <- forM ifaces $ \iface -> do+        -- See Note [Resolving never-exported Names] in GHC.IfaceToCore+        type_env <- fixM $ \type_env -> do+            setImplicitEnvM type_env $ do+                decls <- loadDecls ignore_prags (mi_decls iface)+                return (mkNameEnv decls)+        -- But note that we use this type_env to typecheck references to DFun+        -- in 'IfaceInst'+        setImplicitEnvM type_env $ do+        insts     <- mapM tcIfaceInst (mi_insts iface)+        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        anns      <- tcIfaceAnnotations (mi_anns iface)+        exports   <- ifaceExportNames (mi_exports iface)+        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+        return $ ModDetails { md_types     = type_env+                            , md_insts     = insts+                            , md_fam_insts = fam_insts+                            , md_rules     = rules+                            , md_anns      = anns+                            , md_exports   = exports+                            , md_complete_sigs = complete_sigs+                            }+    return (global_type_env, details)++-- | Typecheck a signature 'ModIface' under the assumption that we have+-- instantiated it under some implementation (recorded in 'mi_semantic_module')+-- and want to check if the implementation fills the signature.+--+-- This needs to operate slightly differently than 'typecheckIface'+-- because (1) we have a 'NameShape', from the exports of the+-- implementing module, which we will use to give our top-level+-- declarations the correct 'Name's even when the implementor+-- provided them with a reexport, and (2) we have to deal with+-- DFun silliness (see Note [rnIfaceNeverExported])+typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails+typecheckIfaceForInstantiate nsubst iface =+  initIfaceLclWithSubst (mi_semantic_module iface)+                        (text "typecheckIfaceForInstantiate")+                        (mi_boot iface) nsubst $ do+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas+    -- See Note [Resolving never-exported Names] in GHC.IfaceToCore+    type_env <- fixM $ \type_env -> do+        setImplicitEnvM type_env $ do+            decls     <- loadDecls ignore_prags (mi_decls iface)+            return (mkNameEnv decls)+    -- See Note [rnIfaceNeverExported]+    setImplicitEnvM type_env $ do+    insts     <- mapM tcIfaceInst (mi_insts iface)+    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+    rules     <- tcIfaceRules ignore_prags (mi_rules iface)+    anns      <- tcIfaceAnnotations (mi_anns iface)+    exports   <- ifaceExportNames (mi_exports iface)+    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+    return $ ModDetails { md_types     = type_env+                        , md_insts     = insts+                        , md_fam_insts = fam_insts+                        , md_rules     = rules+                        , md_anns      = anns+                        , md_exports   = exports+                        , md_complete_sigs = complete_sigs+                        }++-- Note [Resolving never-exported Names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the high-level overview, see+-- Note [Handling never-exported TyThings under Backpack]+--+-- As described in 'typecheckIfacesForMerging', the splendid innovation+-- of signature merging is to rewrite all Names in each of the signatures+-- we are merging together to a pre-merged structure; this is the key+-- ingredient that lets us solve some problems when merging type+-- synonyms.+--+-- However, when a 'Name' refers to a NON-exported entity, as is the+-- case with the DFun of a ClsInst, or a CoAxiom of a type family,+-- this strategy causes problems: if we pick one and rewrite all+-- references to a shared 'Name', we will accidentally fail to check+-- if the DFun or CoAxioms are compatible, as they will never be+-- checked--only exported entities are checked for compatibility,+-- and a non-exported TyThing is checked WHEN we are checking the+-- ClsInst or type family for compatibility in checkBootDeclM.+-- By virtue of the fact that everything's been pointed to the merged+-- declaration, you'll never notice there's a difference even if there+-- is one.+--+-- Fortunately, there are only a few places in the interface declarations+-- where this can occur, so we replace those calls with 'tcIfaceImplicit',+-- which will consult a local TypeEnv that records any never-exported+-- TyThings which we should wire up with.+--+-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a+-- type family can refer to a coercion axiom, all of which are done in one go+-- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck+-- coercions first before type families, but that seemed more fragile.+--++{-+************************************************************************+*                                                                      *+                Type and class declarations+*                                                                      *+************************************************************************+-}++tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo+-- Load the hi-boot iface for the module being compiled,+-- if it indeed exists in the transitive closure of imports+-- Return the ModDetails; Nothing if no hi-boot iface+tcHiBootIface hsc_src mod+  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file+  = return NoSelfBoot+  | otherwise+  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)++        ; mode <- getGhcMode+        ; if not (isOneShot mode)+                -- In --make and interactive mode, if this module has an hs-boot file+                -- we'll have compiled it already, and it'll be in the HPT+                --+                -- We check whether the interface is a *boot* interface.+                -- It can happen (when using GHC from Visual Studio) that we+                -- compile a module in TypecheckOnly mode, with a stable,+                -- fully-populated HPT.  In that case the boot interface isn't there+                -- (it's been replaced by the mother module) so we can't check it.+                -- And that's fine, because if M's ModInfo is in the HPT, then+                -- it's been compiled once, and we don't need to check the boot iface+          then do { hpt <- getHpt+                 ; case lookupHpt hpt (moduleName mod) of+                      Just info | mi_boot (hm_iface info)+                                -> mkSelfBootInfo (hm_iface info) (hm_details info)+                      _ -> return NoSelfBoot }+          else do++        -- OK, so we're in one-shot mode.+        -- Re #9245, we always check if there is an hi-boot interface+        -- to check consistency against, rather than just when we notice+        -- that an hi-boot is necessary due to a circular import.+        { read_result <- findAndReadIface+                                need (fst (splitModuleInsts mod)) mod+                                True    -- Hi-boot file++        ; case read_result of {+            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface+                                           ; mkSelfBootInfo iface tc_iface } ;+            Failed err               ->++        -- There was no hi-boot file. But if there is circularity in+        -- the module graph, there really should have been one.+        -- Since we've read all the direct imports by now,+        -- eps_is_boot will record if any of our imports mention the+        -- current module, which either means a module loop (not+        -- a SOURCE import) or that our hi-boot file has mysteriously+        -- disappeared.+    do  { eps <- getEps+        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of+            Nothing -> return NoSelfBoot -- The typical case++            Just (_, False) -> failWithTc moduleLoop+                -- Someone below us imported us!+                -- This is a loop with no hi-boot in the way++            Just (_mod, True) -> failWithTc (elaborate err)+                -- The hi-boot file has mysteriously disappeared.+    }}}}+  where+    need = text "Need the hi-boot interface for" <+> ppr mod+                 <+> text "to compare against the Real Thing"++    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)+                     <+> text "depends on itself"++    elaborate err = hang (text "Could not find hi-boot interface for" <+>+                          quotes (ppr mod) <> colon) 4 err+++mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo+mkSelfBootInfo iface mds+  = do -- NB: This is computed DIRECTLY from the ModIface rather+       -- than from the ModDetails, so that we can query 'sb_tcs'+       -- WITHOUT forcing the contents of the interface.+       let tcs = map ifName+                 . filter isIfaceTyCon+                 . map snd+                 $ mi_decls iface+       return $ SelfBoot { sb_mds = mds+                         , sb_tcs = mkNameSet tcs }+  where+    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on+    -- this 'IfaceDecl', an ATyCon would be returned.+    -- NB: This code assumes that a TyCon cannot be implicit.+    isIfaceTyCon IfaceId{}      = False+    isIfaceTyCon IfaceData{}    = True+    isIfaceTyCon IfaceSynonym{} = True+    isIfaceTyCon IfaceFamily{}  = True+    isIfaceTyCon IfaceClass{}   = True+    isIfaceTyCon IfaceAxiom{}   = False+    isIfaceTyCon IfacePatSyn{}  = False++{-+************************************************************************+*                                                                      *+                Type and class declarations+*                                                                      *+************************************************************************++When typechecking a data type decl, we *lazily* (via forkM) typecheck+the constructor argument types.  This is in the hope that we may never+poke on those argument types, and hence may never need to load the+interface files for types mentioned in the arg types.++E.g.+        data Foo.S = MkS Baz.T+Maybe we can get away without even loading the interface for Baz!++This is not just a performance thing.  Suppose we have+        data Foo.S = MkS Baz.T+        data Baz.T = MkT Foo.S+(in different interface files, of course).+Now, first we load and typecheck Foo.S, and add it to the type envt.+If we do explore MkS's argument, we'll load and typecheck Baz.T.+If we explore MkT's argument we'll find Foo.S already in the envt.++If we typechecked constructor args eagerly, when loading Foo.S we'd try to+typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...+which isn't done yet.++All very cunning. However, there is a rather subtle gotcha which bit+me when developing this stuff.  When we typecheck the decl for S, we+extend the type envt with S, MkS, and all its implicit Ids.  Suppose+(a bug, but it happened) that the list of implicit Ids depended in+turn on the constructor arg types.  Then the following sequence of+events takes place:+        * we build a thunk <t> for the constructor arg tys+        * we build a thunk for the extended type environment (depends on <t>)+        * we write the extended type envt into the global EPS mutvar++Now we look something up in the type envt+        * that pulls on <t>+        * which reads the global type envt out of the global EPS mutvar+        * but that depends in turn on <t>++It's subtle, because, it'd work fine if we typechecked the constructor args+eagerly -- they don't need the extended type envt.  They just get the extended+type envt by accident, because they look at it later.++What this means is that the implicitTyThings MUST NOT DEPEND on any of+the forkM stuff.+-}++tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings+            -> IfaceDecl+            -> IfL TyThing+tcIfaceDecl = tc_iface_decl Nothing++tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations+              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings+              -> IfaceDecl+              -> IfL TyThing+tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,+                                       ifIdDetails = details, ifIdInfo = info})+  = do  { ty <- tcIfaceType iface_type+        ; details <- tcIdDetails ty details+        ; info <- tcIdInfo ignore_prags TopLevel name ty info+        ; return (AnId (mkGlobalId details name ty info)) }++tc_iface_decl _ _ (IfaceData {ifName = tc_name,+                          ifCType = cType,+                          ifBinders = binders,+                          ifResKind = res_kind,+                          ifRoles = roles,+                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,+                          ifCons = rdr_cons,+                          ifParent = mb_parent })+  = bindIfaceTyConBinders_AT binders $ \ binders' -> do+    { res_kind' <- tcIfaceType res_kind++    ; tycon <- fixM $ \ tycon -> do+            { stupid_theta <- tcIfaceCtxt ctxt+            ; parent' <- tc_parent tc_name mb_parent+            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons+            ; return (mkAlgTyCon tc_name binders' res_kind'+                                 roles cType stupid_theta+                                 cons parent' gadt_syn) }+    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)+    ; return (ATyCon tycon) }+  where+    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav+    tc_parent tc_name IfNoParent+      = do { tc_rep_name <- newTyConRepName tc_name+           ; return (VanillaAlgTyCon tc_rep_name) }+    tc_parent _ (IfDataInstance ax_name _ arg_tys)+      = do { ax <- tcIfaceCoAxiom ax_name+           ; let fam_tc  = coAxiomTyCon ax+                 ax_unbr = toUnbranchedAxiom ax+           ; lhs_tys <- tcIfaceAppArgs arg_tys+           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }++tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,+                                      ifRoles = roles,+                                      ifSynRhs = rhs_ty,+                                      ifBinders = binders,+                                      ifResKind = res_kind })+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do+     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]+     ; rhs      <- forkM (mk_doc tc_name) $+                   tcIfaceType rhs_ty+     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs+     ; return (ATyCon tycon) }+   where+     mk_doc n = text "Type synonym" <+> ppr n++tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,+                                     ifFamFlav = fam_flav,+                                     ifBinders = binders,+                                     ifResKind = res_kind,+                                     ifResVar = res, ifFamInj = inj })+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do+     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]+     ; rhs      <- forkM (mk_doc tc_name) $+                   tc_fam_flav tc_name fam_flav+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res+     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj+     ; return (ATyCon tycon) }+   where+     mk_doc n = text "Type synonym" <+> ppr n++     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav+     tc_fam_flav tc_name IfaceDataFamilyTyCon+       = do { tc_rep_name <- newTyConRepName tc_name+            ; return (DataFamilyTyCon tc_rep_name) }+     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon+     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)+       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches+            ; return (ClosedSynFamilyTyCon ax) }+     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon+         = return AbstractClosedSynFamilyTyCon+     tc_fam_flav _ IfaceBuiltInSynFamTyCon+         = pprPanic "tc_iface_decl"+                    (text "IfaceBuiltInSynFamTyCon in interface file")++tc_iface_decl _parent _ignore_prags+            (IfaceClass {ifName = tc_name,+                         ifRoles = roles,+                         ifBinders = binders,+                         ifFDs = rdr_fds,+                         ifBody = IfAbstractClass})+  = bindIfaceTyConBinders binders $ \ binders' -> do+    { fds  <- mapM tc_fd rdr_fds+    ; cls  <- buildClass tc_name binders' roles fds Nothing+    ; return (ATyCon (classTyCon cls)) }++tc_iface_decl _parent ignore_prags+            (IfaceClass {ifName = tc_name,+                         ifRoles = roles,+                         ifBinders = binders,+                         ifFDs = rdr_fds,+                         ifBody = IfConcreteClass {+                             ifClassCtxt = rdr_ctxt,+                             ifATs = rdr_ats, ifSigs = rdr_sigs,+                             ifMinDef = mindef_occ+                         }})+  = bindIfaceTyConBinders binders $ \ binders' -> do+    { traceIf (text "tc-iface-class1" <+> ppr tc_name)+    ; ctxt <- mapM tc_sc rdr_ctxt+    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)+    ; sigs <- mapM tc_sig rdr_sigs+    ; fds  <- mapM tc_fd rdr_fds+    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ+    ; cls  <- fixM $ \ cls -> do+              { ats  <- mapM (tc_at cls) rdr_ats+              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)+              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }+    ; return (ATyCon (classTyCon cls)) }+  where+   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)+        -- The *length* of the superclasses is used by buildClass, and hence must+        -- not be inside the thunk.  But the *content* maybe recursive and hence+        -- must be lazy (via forkM).  Example:+        --     class C (T a) => D a where+        --       data T a+        -- Here the associated type T is knot-tied with the class, and+        -- so we must not pull on T too eagerly.  See #5970++   tc_sig :: IfaceClassOp -> IfL TcMethInfo+   tc_sig (IfaceClassOp op_name rdr_ty dm)+     = do { let doc = mk_op_doc op_name rdr_ty+          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty+                -- Must be done lazily for just the same reason as the+                -- type of a data con; to avoid sucking in types that+                -- it mentions unless it's necessary to do so+          ; dm'   <- tc_dm doc dm+          ; return (op_name, op_ty, dm') }++   tc_dm :: SDoc+         -> Maybe (DefMethSpec IfaceType)+         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))+   tc_dm _   Nothing               = return Nothing+   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)+   tc_dm doc (Just (GenericDM ty))+        = do { -- Must be done lazily to avoid sucking in types+             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty+             ; return (Just (GenericDM (noSrcSpan, ty'))) }++   tc_at cls (IfaceAT tc_decl if_def)+     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl+          mb_def <- case if_def of+                      Nothing  -> return Nothing+                      Just def -> forkM (mk_at_doc tc)                 $+                                  extendIfaceTyVarEnv (tyConTyVars tc) $+                                  do { tc_def <- tcIfaceType def+                                     ; return (Just (tc_def, noSrcSpan)) }+                  -- Must be done lazily in case the RHS of the defaults mention+                  -- the type constructor being defined here+                  -- e.g.   type AT a; type AT b = AT [b]   #8002+          return (ATI tc mb_def)++   mk_sc_doc pred = text "Superclass" <+> ppr pred+   mk_at_doc tc = text "Associated type" <+> ppr tc+   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]++tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc+                              , ifAxBranches = branches, ifRole = role })+  = do { tc_tycon    <- tcIfaceTyCon tc+       -- Must be done lazily, because axioms are forced when checking+       -- for family instance consistency, and the RHS may mention+       -- a hs-boot declared type constructor that is going to be+       -- defined by this module.+       -- e.g. type instance F Int = ToBeDefined+       -- See #13803+       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)+                      $ tc_ax_branches branches+       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name+                             , co_ax_name     = tc_name+                             , co_ax_tc       = tc_tycon+                             , co_ax_role     = role+                             , co_ax_branches = manyBranches tc_branches+                             , co_ax_implicit = False }+       ; return (ACoAxiom axiom) }++tc_iface_decl _ _ (IfacePatSyn{ ifName = name+                              , ifPatMatcher = if_matcher+                              , ifPatBuilder = if_builder+                              , ifPatIsInfix = is_infix+                              , ifPatUnivBndrs = univ_bndrs+                              , ifPatExBndrs = ex_bndrs+                              , ifPatProvCtxt = prov_ctxt+                              , ifPatReqCtxt = req_ctxt+                              , ifPatArgs = args+                              , ifPatTy = pat_ty+                              , ifFieldLabels = field_labels })+  = do { traceIf (text "tc_iface_decl" <+> ppr name)+       ; matcher <- tc_pr if_matcher+       ; builder <- fmapMaybeM tc_pr if_builder+       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do+       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do+       { patsyn <- forkM (mk_doc name) $+             do { prov_theta <- tcIfaceCtxt prov_ctxt+                ; req_theta  <- tcIfaceCtxt req_ctxt+                ; pat_ty     <- tcIfaceType pat_ty+                ; arg_tys    <- mapM tcIfaceType args+                ; return $ buildPatSyn name is_infix matcher builder+                                       (univ_tvs, req_theta)+                                       (ex_tvs, prov_theta)+                                       arg_tys pat_ty field_labels }+       ; return $ AConLike . PatSynCon $ patsyn }}}+  where+     mk_doc n = text "Pattern synonym" <+> ppr n+     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)+     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)+                        ; return (id, b) }++tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)+tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1+                        ; tvs2' <- mapM tcIfaceTyVar tvs2+                        ; return (tvs1', tvs2') }++tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches++tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]+tc_ax_branch prev_branches+             (IfaceAxBranch { ifaxbTyVars = tv_bndrs+                            , ifaxbEtaTyVars = eta_tv_bndrs+                            , ifaxbCoVars = cv_bndrs+                            , ifaxbLHS = lhs, ifaxbRHS = rhs+                            , ifaxbRoles = roles, ifaxbIncomps = incomps })+  = bindIfaceTyConBinders_AT+      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->+         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom+    bindIfaceIds cv_bndrs $ \ cvs -> do+    { tc_lhs   <- tcIfaceAppArgs lhs+    ; tc_rhs   <- tcIfaceType rhs+    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return+    ; this_mod <- getIfModule+    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`+                                  moduleNameFS (moduleName this_mod))+          br = CoAxBranch { cab_loc     = loc+                          , cab_tvs     = binderVars tvs+                          , cab_eta_tvs = eta_tvs+                          , cab_cvs     = cvs+                          , cab_lhs     = tc_lhs+                          , cab_roles   = roles+                          , cab_rhs     = tc_rhs+                          , cab_incomps = map (prev_branches `getNth`) incomps }+    ; return (prev_branches ++ [br]) }++tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs+tcIfaceDataCons tycon_name tycon tc_tybinders if_cons+  = case if_cons of+        IfAbstractTyCon  -> return AbstractTyCon+        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons+                                ; return (mkDataTyConRhs data_cons) }+        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con+                                ; mkNewTyConRhs tycon_name tycon data_con }+  where+    univ_tvs :: [TyVar]+    univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)++    tag_map :: NameEnv ConTag+    tag_map = mkTyConTagMap tycon++    tc_con_decl (IfCon { ifConInfix = is_infix,+                         ifConExTCvs = ex_bndrs,+                         ifConUserTvBinders = user_bndrs,+                         ifConName = dc_name,+                         ifConCtxt = ctxt, ifConEqSpec = spec,+                         ifConArgTys = args, ifConFields = lbl_names,+                         ifConStricts = if_stricts,+                         ifConSrcStricts = if_src_stricts})+     = -- Universally-quantified tyvars are shared with+       -- parent TyCon, and are already in scope+       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do+        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)++          -- By this point, we have bound every universal and existential+          -- tyvar. Because of the dcUserTyVarBinders invariant+          -- (see Note [DataCon user type variable binders]), *every* tyvar in+          -- ifConUserTvBinders has a matching counterpart somewhere in the+          -- bound universals/existentials. As a result, calling tcIfaceTyVar+          -- below is always guaranteed to succeed.+        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->+                                   case bd of+                                     IfaceIdBndr (name, _) ->+                                       Bndr <$> tcIfaceLclId name <*> pure vis+                                     IfaceTvBndr (name, _) ->+                                       Bndr <$> tcIfaceTyVar name <*> pure vis)+                                user_bndrs++        -- Read the context and argument types, but lazily for two reasons+        -- (a) to avoid looking tugging on a recursive use of+        --     the type itself, which is knot-tied+        -- (b) to avoid faulting in the component types unless+        --     they are really needed+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $+             do { eq_spec <- tcIfaceEqSpec spec+                ; theta   <- tcIfaceCtxt ctxt+                -- This fixes #13710.  The enclosing lazy thunk gets+                -- forced when typechecking record wildcard pattern+                -- matching (it's not completely clear why this+                -- tuple is needed), which causes trouble if one of+                -- the argument types was recursively defined.+                -- See also Note [Tying the knot]+                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")+                           $ mapM tcIfaceType args+                ; stricts <- mapM tc_strict if_stricts+                        -- The IfBang field can mention+                        -- the type itself; hence inside forkM+                ; return (eq_spec, theta, arg_tys, stricts) }++        -- Remember, tycon is the representation tycon+        ; let orig_res_ty = mkFamilyTyConApp tycon+                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))+                                             (binderVars tc_tybinders))++        ; prom_rep_name <- newTyConRepName dc_name++        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))+                       dc_name is_infix prom_rep_name+                       (map src_strict if_src_stricts)+                       (Just stricts)+                       -- Pass the HsImplBangs (i.e. final+                       -- decisions) to buildDataCon; it'll use+                       -- these to guide the construction of a+                       -- worker.+                       -- See Note [Bangs on imported data constructors] in MkId+                       lbl_names+                       univ_tvs ex_tvs user_tv_bndrs+                       eq_spec theta+                       arg_tys orig_res_ty tycon tag_map+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)+        ; return con }+    mk_doc con_name = text "Constructor" <+> ppr con_name++    tc_strict :: IfaceBang -> IfL HsImplBang+    tc_strict IfNoBang = return (HsLazy)+    tc_strict IfStrict = return (HsStrict)+    tc_strict IfUnpack = return (HsUnpack Nothing)+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co+                                      ; return (HsUnpack (Just co)) }++    src_strict :: IfaceSrcBang -> HsSrcBang+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang++tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]+tcIfaceEqSpec spec+  = mapM do_item spec+  where+    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ+                              ; ty <- tcIfaceType if_ty+                              ; return (mkEqSpec tv ty) }++{-+Note [Synonym kind loop]+~~~~~~~~~~~~~~~~~~~~~~~~+Notice that we eagerly grab the *kind* from the interface file, but+build a forkM thunk for the *rhs* (and family stuff).  To see why,+consider this (#2412)++M.hs:       module M where { import X; data T = MkT S }+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }+M.hs-boot:  module M where { data T }++When kind-checking M.hs we need S's kind.  But we do not want to+find S's kind from (typeKind S-rhs), because we don't want to look at+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to+be defined, and we must not do that until we've finished with M.T.++Solution: record S's kind in the interface file; now we can safely+look at it.++************************************************************************+*                                                                      *+                Instances+*                                                                      *+************************************************************************+-}++tcIfaceInst :: IfaceClsInst -> IfL ClsInst+tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag+                          , ifInstCls = cls, ifInstTys = mb_tcs+                          , ifInstOrph = orph })+  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $+                    fmap tyThingId (tcIfaceImplicit dfun_name)+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs+       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }++tcIfaceFamInst :: IfaceFamInst -> IfL FamInst+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs+                             , ifFamInstAxiom = axiom_name } )+    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $+                     tcIfaceCoAxiom axiom_name+             -- will panic if branched, but that's OK+         ; let axiom'' = toUnbranchedAxiom axiom'+               mb_tcs' = map (fmap ifaceTyConName) mb_tcs+         ; return (mkImportedFamInst fam mb_tcs' axiom'') }++{-+************************************************************************+*                                                                      *+                Rules+*                                                                      *+************************************************************************++We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars+are in the type environment.  However, remember that typechecking a Rule may+(as a side effect) augment the type envt, and so we may need to iterate the process.+-}++tcIfaceRules :: Bool            -- True <=> ignore rules+             -> [IfaceRule]+             -> IfL [CoreRule]+tcIfaceRules ignore_prags if_rules+  | ignore_prags = return []+  | otherwise    = mapM tcIfaceRule if_rules++tcIfaceRule :: IfaceRule -> IfL CoreRule+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,+                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,+                        ifRuleAuto = auto, ifRuleOrph = orph })+  = do  { ~(bndrs', args', rhs') <-+                -- Typecheck the payload lazily, in the hope it'll never be looked at+                forkM (text "Rule" <+> pprRuleName name) $+                bindIfaceBndrs bndrs                      $ \ bndrs' ->+                do { args' <- mapM tcIfaceExpr args+                   ; rhs'  <- tcIfaceExpr rhs+                   ; return (bndrs', args', rhs') }+        ; let mb_tcs = map ifTopFreeName args+        ; this_mod <- getIfModule+        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,+                          ru_bndrs = bndrs', ru_args = args',+                          ru_rhs = occurAnalyseExpr rhs',+                          ru_rough = mb_tcs,+                          ru_origin = this_mod,+                          ru_orphan = orph,+                          ru_auto = auto,+                          ru_local = False }) } -- An imported RULE is never for a local Id+                                                -- or, even if it is (module loop, perhaps)+                                                -- we'll just leave it in the non-local set+  where+        -- This function *must* mirror exactly what Rules.roughTopNames does+        -- We could have stored the ru_rough field in the iface file+        -- but that would be redundant, I think.+        -- The only wrinkle is that we must not be deceived by+        -- type synonyms at the top of a type arg.  Since+        -- we can't tell at this point, we are careful not+        -- to write them out in coreRuleToIfaceRule+    ifTopFreeName :: IfaceExpr -> Maybe Name+    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)+    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))+    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f+    ifTopFreeName (IfaceExt n)                      = Just n+    ifTopFreeName _                                 = Nothing++{-+************************************************************************+*                                                                      *+                Annotations+*                                                                      *+************************************************************************+-}++tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceAnnotations = mapM tcIfaceAnnotation++tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation+tcIfaceAnnotation (IfaceAnnotation target serialized) = do+    target' <- tcIfaceAnnTarget target+    return $ Annotation {+        ann_target = target',+        ann_value = serialized+    }++tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)+tcIfaceAnnTarget (NamedTarget occ) = do+    name <- lookupIfaceTop occ+    return $ NamedTarget name+tcIfaceAnnTarget (ModuleTarget mod) = do+    return $ ModuleTarget mod++{-+************************************************************************+*                                                                      *+                Complete Match Pragmas+*                                                                      *+************************************************************************+-}++tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig++tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch+tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)++{-+************************************************************************+*                                                                      *+                        Types+*                                                                      *+************************************************************************+-}++tcIfaceType :: IfaceType -> IfL Type+tcIfaceType = go+  where+    go (IfaceTyVar n)          = TyVarTy <$> tcIfaceTyVar n+    go (IfaceFreeTyVar n)      = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)+    go (IfaceLitTy l)          = LitTy <$> tcIfaceTyLit l+    go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2+    go (IfaceTupleTy s i tks)  = tcIfaceTupleTy s i tks+    go (IfaceAppTy t ts)+      = do { t'  <- go t+           ; ts' <- traverse go (appArgsIfaceTypes ts)+           ; pure (foldl' AppTy t' ts') }+    go (IfaceTyConApp tc tks)+      = do { tc' <- tcIfaceTyCon tc+           ; tks' <- mapM go (appArgsIfaceTypes tks)+           ; return (mkTyConApp tc' tks') }+    go (IfaceForAllTy bndr t)+      = bindIfaceForAllBndr bndr $ \ tv' vis ->+        ForAllTy (Bndr tv' vis) <$> go t+    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co+    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co++tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type+tcIfaceTupleTy sort is_promoted args+ = do { args' <- tcIfaceAppArgs args+      ; let arity = length args'+      ; base_tc <- tcTupleTyCon True sort arity+      ; case is_promoted of+          NotPromoted+            -> return (mkTyConApp base_tc args')++          IsPromoted+            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)+                        kind_args = map typeKind args'+                  ; return (mkTyConApp tc (kind_args ++ args')) } }++-- See Note [Unboxed tuple RuntimeRep vars] in TyCon+tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)+             -> TupleSort+             -> Arity   -- the number of args. *not* the tuple arity.+             -> IfL TyCon+tcTupleTyCon in_type sort arity+  = case sort of+      ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)+                            ; return (tyThingTyCon thing) }+      BoxedTuple   -> return (tupleTyCon Boxed   arity)+      UnboxedTuple -> return (tupleTyCon Unboxed arity')+        where arity' | in_type   = arity `div` 2+                     | otherwise = arity+                      -- in expressions, we only have term args++tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]+tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes++-----------------------------------------+tcIfaceCtxt :: IfaceContext -> IfL ThetaType+tcIfaceCtxt sts = mapM tcIfaceType sts++-----------------------------------------+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit+tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)++{-+%************************************************************************+%*                                                                      *+                        Coercions+*                                                                      *+************************************************************************+-}++tcIfaceCo :: IfaceCoercion -> IfL Coercion+tcIfaceCo = go+  where+    go_mco IfaceMRefl    = pure MRefl+    go_mco (IfaceMCo co) = MCo <$> (go co)++    go (IfaceReflCo t)           = Refl <$> tcIfaceType t+    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco+    go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2+    go (IfaceTyConAppCo r tc cs)+      = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs+    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2+    go (IfaceForAllCo tv k c)  = do { k' <- go k+                                      ; bindIfaceBndr tv $ \ tv' ->+                                        ForAllCo tv' k' <$> go c }+    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n+    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs+    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r+                                          <*> tcIfaceType t1 <*> tcIfaceType t2+    go (IfaceSymCo c)            = SymCo    <$> go c+    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1+                                            <*> go c2+    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1+                                            <*> go t2+    go (IfaceNthCo d c)          = do { c' <- go c+                                      ; return $ mkNthCo (nthCoRole d c') d c' }+    go (IfaceLRCo lr c)          = LRCo lr  <$> go c+    go (IfaceKindCo c)           = KindCo   <$> go c+    go (IfaceSubCo c)            = SubCo    <$> go c+    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax+                                               <*> mapM go cos+    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)+    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)++    go_var :: FastString -> IfL CoVar+    go_var = tcIfaceLclId++tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance+tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv+tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco+tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str++{-+************************************************************************+*                                                                      *+                        Core+*                                                                      *+************************************************************************+-}++tcIfaceExpr :: IfaceExpr -> IfL CoreExpr+tcIfaceExpr (IfaceType ty)+  = Type <$> tcIfaceType ty++tcIfaceExpr (IfaceCo co)+  = Coercion <$> tcIfaceCo co++tcIfaceExpr (IfaceCast expr co)+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co++tcIfaceExpr (IfaceLcl name)+  = Var <$> tcIfaceLclId name++tcIfaceExpr (IfaceExt gbl)+  = Var <$> tcIfaceExtId gbl++tcIfaceExpr (IfaceLit lit)+  = do lit' <- tcIfaceLit lit+       return (Lit lit')++tcIfaceExpr (IfaceFCall cc ty) = do+    ty' <- tcIfaceType ty+    u <- newUnique+    dflags <- getDynFlags+    return (Var (mkFCallId dflags u cc ty'))++tcIfaceExpr (IfaceTuple sort args)+  = do { args' <- mapM tcIfaceExpr args+       ; tc <- tcTupleTyCon False sort arity+       ; let con_tys = map exprType args'+             some_con_args = map Type con_tys ++ args'+             con_args = case sort of+               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args+               _            -> some_con_args+                        -- Put the missing type arguments back in+             con_id   = dataConWorkId (tyConSingleDataCon tc)+       ; return (mkApps (Var con_id) con_args) }+  where+    arity = length args++tcIfaceExpr (IfaceLam (bndr, os) body)+  = bindIfaceBndr bndr $ \bndr' ->+    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body+  where+    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b+    tcIfaceOneShot _            b = b++tcIfaceExpr (IfaceApp fun arg)+  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg++tcIfaceExpr (IfaceECase scrut ty)+  = do { scrut' <- tcIfaceExpr scrut+       ; ty' <- tcIfaceType ty+       ; return (castBottomExpr scrut' ty') }++tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do+    scrut' <- tcIfaceExpr scrut+    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)+    let+        scrut_ty   = exprType scrut'+        case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty+     -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors+     -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.+        tc_app     = splitTyConApp scrut_ty+                -- NB: Won't always succeed (polymorphic case)+                --     but won't be demanded in those cases+                -- NB: not tcSplitTyConApp; we are looking at Core here+                --     look through non-rec newtypes to find the tycon that+                --     corresponds to the datacon in this case alternative++    extendIfaceIdEnv [case_bndr'] $ do+     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts+     return (Case scrut' case_bndr' (coreAltsType alts') alts')++tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)+  = do  { name    <- newIfaceName (mkVarOccFS fs)+        ; ty'     <- tcIfaceType ty+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}+                              NotTopLevel name ty' info+        ; let id = mkLocalIdWithInfo name ty' id_info+                     `asJoinId_maybe` tcJoinInfo ji+        ; rhs' <- tcIfaceExpr rhs+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)+        ; return (Let (NonRec id rhs') body') }++tcIfaceExpr (IfaceLet (IfaceRec pairs) body)+  = do { ids <- mapM tc_rec_bndr (map fst pairs)+       ; extendIfaceIdEnv ids $ do+       { pairs' <- zipWithM tc_pair pairs ids+       ; body' <- tcIfaceExpr body+       ; return (Let (Rec pairs') body') } }+ where+   tc_rec_bndr (IfLetBndr fs ty _ ji)+     = do { name <- newIfaceName (mkVarOccFS fs)+          ; ty'  <- tcIfaceType ty+          ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }+   tc_pair (IfLetBndr _ _ info _, rhs) id+     = do { rhs' <- tcIfaceExpr rhs+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}+                                NotTopLevel (idName id) (idType id) info+          ; return (setIdInfo id id_info, rhs') }++tcIfaceExpr (IfaceTick tickish expr) = do+    expr' <- tcIfaceExpr expr+    -- If debug flag is not set: Ignore source notes+    dbgLvl <- fmap debugLevel getDynFlags+    case tickish of+      IfaceSource{} | dbgLvl == 0+                    -> return expr'+      _otherwise    -> do+        tickish' <- tcIfaceTickish tickish+        return (Tick tickish' expr')++-------------------------+tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)+tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)+tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)+tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)++-------------------------+tcIfaceLit :: Literal -> IfL Literal+-- Integer literals deserialise to (LitInteger i <error thunk>)+-- so tcIfaceLit just fills in the type.+-- See Note [Integer literals] in Literal+tcIfaceLit (LitNumber LitNumInteger i _)+  = do t <- tcIfaceTyConByName integerTyConName+       return (mkLitInteger i (mkTyConTy t))+-- Natural literals deserialise to (LitNatural i <error thunk>)+-- so tcIfaceLit just fills in the type.+-- See Note [Natural literals] in Literal+tcIfaceLit (LitNumber LitNumNatural i _)+  = do t <- tcIfaceTyConByName naturalTyConName+       return (mkLitNatural i (mkTyConTy t))+tcIfaceLit lit = return lit++-------------------------+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])+           -> (IfaceConAlt, [FastString], IfaceExpr)+           -> IfL (AltCon, [TyVar], CoreExpr)+tcIfaceAlt _ _ (IfaceDefault, names, rhs)+  = ASSERT( null names ) do+    rhs' <- tcIfaceExpr rhs+    return (DEFAULT, [], rhs')++tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)+  = ASSERT( null names ) do+    lit' <- tcIfaceLit lit+    rhs' <- tcIfaceExpr rhs+    return (LitAlt lit', [], rhs')++-- A case alternative is made quite a bit more complicated+-- by the fact that we omit type annotations because we can+-- work them out.  True enough, but its not that easy!+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)+  = do  { con <- tcIfaceDataCon data_occ+        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))+               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))+        ; tcIfaceDataAlt con inst_tys arg_strs rhs }++tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr+               -> IfL (AltCon, [TyVar], CoreExpr)+tcIfaceDataAlt con inst_tys arg_strs rhs+  = do  { us <- newUniqueSupply+        ; let uniqs = uniqsFromSupply us+        ; let (ex_tvs, arg_ids)+                      = dataConRepFSInstPat arg_strs uniqs con inst_tys++        ; rhs' <- extendIfaceEnvs  ex_tvs       $+                  extendIfaceIdEnv arg_ids      $+                  tcIfaceExpr rhs+        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }++{-+************************************************************************+*                                                                      *+                IdInfo+*                                                                      *+************************************************************************+-}++tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails+tcIdDetails _  IfVanillaId = return VanillaId+tcIdDetails ty IfDFunId+  = return (DFunId (isNewTyCon (classTyCon cls)))+  where+    (_, _, cls, _) = tcSplitDFunTy ty++tcIdDetails _ (IfRecSelId tc naughty)+  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)+                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)+                       tc+       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }+  where+    tyThingPatSyn (AConLike (PatSynCon ps)) = ps+    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"++tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo+tcIdInfo ignore_prags toplvl name ty info = do+    lcl_env <- getLclEnv+    -- Set the CgInfo to something sensible but uninformative before+    -- we start; default assumption is that it has CAFs+    let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding+                  | otherwise       = vanillaIdInfo+    if ignore_prags+        then return init_info+        else case info of+                NoInfo -> return init_info+                HasInfo info -> foldlM tcPrag init_info info+  where+    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo+    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)+    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)+    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)+    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)+    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)++        -- The next two are lazy, so they don't transitively suck stuff in+    tcPrag info (HsUnfold lb if_unf)+      = do { unf <- tcUnfolding toplvl name ty info if_unf+           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker+                       | otherwise = info+           ; return (info1 `setUnfoldingInfo` unf) }++tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity+tcJoinInfo (IfaceJoinPoint ar) = Just ar+tcJoinInfo IfaceNotJoinPoint   = Nothing++tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding+tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)+  = do  { dflags <- getDynFlags+        ; mb_expr <- tcPragExpr toplvl name if_expr+        ; let unf_src | stable    = InlineStable+                      | otherwise = InlineRhs+        ; return $ case mb_expr of+            Nothing -> NoUnfolding+            Just expr -> mkUnfolding dflags unf_src+                           True {- Top level -}+                           (isBottomingSig strict_sig)+                           expr+        }+  where+     -- Strictness should occur before unfolding!+    strict_sig = strictnessInfo info+tcUnfolding toplvl name _ _ (IfCompulsory if_expr)+  = do  { mb_expr <- tcPragExpr toplvl name if_expr+        ; return (case mb_expr of+                    Nothing   -> NoUnfolding+                    Just expr -> mkCompulsoryUnfolding expr) }++tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)+  = do  { mb_expr <- tcPragExpr toplvl name if_expr+        ; return (case mb_expr of+                    Nothing   -> NoUnfolding+                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}+  where+    guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }++tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)+  = bindIfaceBndrs bs $ \ bs' ->+    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops+       ; return (case mb_ops1 of+                    Nothing   -> noUnfolding+                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }+  where+    doc = text "Class ops for dfun" <+> ppr name+    (_, _, cls, _) = tcSplitDFunTy dfun_ty++{-+For unfoldings we try to do the job lazily, so that we never type check+an unfolding that isn't going to be looked at.+-}++tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)+tcPragExpr toplvl name expr+  = forkM_maybe doc $ do+    core_expr' <- tcIfaceExpr expr++    -- Check for type consistency in the unfolding+    -- See Note [Linting Unfoldings from Interfaces]+    when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do+        in_scope <- get_in_scope+        dflags   <- getDynFlags+        case lintUnfolding dflags noSrcLoc in_scope core_expr' of+          Nothing       -> return ()+          Just fail_msg -> do { mod <- getIfModule+                              ; pprPanic "Iface Lint failure"+                                  (vcat [ text "In interface for" <+> ppr mod+                                        , hang doc 2 fail_msg+                                        , ppr name <+> equals <+> ppr core_expr'+                                        , text "Iface expr =" <+> ppr expr ]) }+    return core_expr'+  where+    doc = text "Unfolding of" <+> ppr name++    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting+    get_in_scope+        = do { (gbl_env, lcl_env) <- getEnvs+             ; rec_ids <- case if_rec_types gbl_env of+                            Nothing -> return []+                            Just (_, get_env) -> do+                               { type_env <- setLclEnv () get_env+                               ; return (typeEnvIds type_env) }+             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`+                       bindingsVars (if_id_env lcl_env) `unionVarSet`+                       mkVarSet rec_ids) }++    bindingsVars :: FastStringEnv Var -> VarSet+    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm+      -- It's OK to use nonDetEltsUFM here because we immediately forget+      -- the ordering by creating a set++{-+************************************************************************+*                                                                      *+                Getting from Names to TyThings+*                                                                      *+************************************************************************+-}++tcIfaceGlobal :: Name -> IfL TyThing+tcIfaceGlobal name+  | Just thing <- wiredInNameTyThing_maybe name+        -- Wired-in things include TyCons, DataCons, and Ids+        -- Even though we are in an interface file, we want to make+        -- sure the instances and RULES of this thing (particularly TyCon) are loaded+        -- Imagine: f :: Double -> Double+  = do { ifCheckWiredInThing thing; return thing }++  | otherwise+  = do  { env <- getGblEnv+        ; case if_rec_types env of {    -- Note [Tying the knot]+            Just (mod, get_type_env)+                | nameIsLocalOrFrom mod name+                -> do           -- It's defined in the module being compiled+                { type_env <- setLclEnv () get_type_env         -- yuk+                ; case lookupNameEnv type_env name of+                    Just thing -> return thing+                    -- See Note [Knot-tying fallback on boot]+                    Nothing   -> via_external+                }++          ; _ -> via_external }}+  where+    via_external =  do+        { hsc_env <- getTopEnv+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; case mb_thing of {+            Just thing -> return thing ;+            Nothing    -> do++        { mb_thing <- importDecl name   -- It's imported; go get it+        ; case mb_thing of+            Failed err      -> failIfM err+            Succeeded thing -> return thing+        }}}++-- Note [Tying the knot]+-- ~~~~~~~~~~~~~~~~~~~~~+-- The if_rec_types field is used when we are compiling M.hs, which indirectly+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type+-- environment, which is splatted into if_rec_types after we've built M's type+-- envt.+--+-- This is a dark and complicated part of GHC type checking, with a lot+-- of moving parts.  Interested readers should also look at:+--+--      * Note [Knot-tying typecheckIface]+--      * Note [DFun knot-tying]+--      * Note [hsc_type_env_var hack]+--      * Note [Knot-tying fallback on boot]+--+-- There is also a wiki page on the subject, see:+--+--      https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot++-- Note [Knot-tying fallback on boot]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Suppose that you are typechecking A.hs, which transitively imports,+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it+-- has a reference to a type T from A, what TyThing should we wire+-- it up with? Clearly, if we have already typechecked T and+-- added it into the type environment, we should go ahead and use that+-- type. But what if we haven't typechecked it yet?+--+-- For the longest time, GHC adopted the policy that this was+-- *an error condition*; that you MUST NEVER poke on B.hs's reference+-- to a T defined in A.hs until A.hs has gotten around to kind-checking+-- T and adding it to the env. However, actually ensuring this is the+-- case has proven to be a bug farm, because it's really difficult to+-- actually ensure this never happens. The problem was especially poignant+-- with type family consistency checks, which eagerly happen before any+-- typechecking takes place.+--+-- Today, we take a different strategy: if we ever try to access+-- an entity from A which doesn't exist, we just fall back on the+-- definition of A from the hs-boot file. This is complicated in+-- its own way: it means that you may end up with a mix of A.hs and+-- A.hs-boot TyThings during the course of typechecking.  We don't+-- think (and have not observed) any cases where this would cause+-- problems, but the hypothetical situation one might worry about+-- is something along these lines in Core:+--+--    case x of+--        A -> e1+--        B -> e2+--+-- If, when typechecking this, we find x :: T, and the T we are hooked+-- up with is the abstract one from the hs-boot file, rather than the+-- one defined in this module with constructors A and B.  But it's hard+-- to see how this could happen, especially because the reference to+-- the constructor (A and B) means that GHC will always typecheck+-- this expression *after* typechecking T.++tcIfaceTyConByName :: IfExtName -> IfL TyCon+tcIfaceTyConByName name+  = do { thing <- tcIfaceGlobal name+       ; return (tyThingTyCon thing) }++tcIfaceTyCon :: IfaceTyCon -> IfL TyCon+tcIfaceTyCon (IfaceTyCon name info)+  = do { thing <- tcIfaceGlobal name+       ; return $ case ifaceTyConIsPromoted info of+           NotPromoted -> tyThingTyCon thing+           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }++tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)+tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name+                         ; return (tyThingCoAxiom thing) }+++tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule+-- Unlike CoAxioms, which arise form user 'type instance' declarations,+-- there are a fixed set of CoAxiomRules,+-- currently enumerated in typeNatCoAxiomRules+tcIfaceCoAxiomRule n+  = case Map.lookup n typeNatCoAxiomRules of+        Just ax -> return ax+        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)++tcIfaceDataCon :: Name -> IfL DataCon+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name+                         ; case thing of+                                AConLike (RealDataCon dc) -> return dc+                                _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }++tcIfaceExtId :: Name -> IfL Id+tcIfaceExtId name = do { thing <- tcIfaceGlobal name+                       ; case thing of+                          AnId id -> return id+                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }++-- See Note [Resolving never-exported Names] in GHC.IfaceToCore+tcIfaceImplicit :: Name -> IfL TyThing+tcIfaceImplicit n = do+    lcl_env <- getLclEnv+    case if_implicits_env lcl_env of+        Nothing -> tcIfaceGlobal n+        Just tenv ->+            case lookupTypeEnv tenv n of+                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)+                Just tything -> return tything++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************+-}++bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a+bindIfaceId (fs, ty) thing_inside+  = do  { name <- newIfaceName (mkVarOccFS fs)+        ; ty' <- tcIfaceType ty+        ; let id = mkLocalIdOrCoVar name ty'+          -- We should not have "OrCoVar" here, this is a bug (#17545)+        ; extendIfaceIdEnv [id] (thing_inside id) }++bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a+bindIfaceIds [] thing_inside = thing_inside []+bindIfaceIds (b:bs) thing_inside+  = bindIfaceId b   $ \b'  ->+    bindIfaceIds bs $ \bs' ->+    thing_inside (b':bs')++bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a+bindIfaceBndr (IfaceIdBndr bndr) thing_inside+  = bindIfaceId bndr thing_inside+bindIfaceBndr (IfaceTvBndr bndr) thing_inside+  = bindIfaceTyVar bndr thing_inside++bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a+bindIfaceBndrs []     thing_inside = thing_inside []+bindIfaceBndrs (b:bs) thing_inside+  = bindIfaceBndr b     $ \ b' ->+    bindIfaceBndrs bs   $ \ bs' ->+    thing_inside (b':bs')++-----------------------+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a+bindIfaceForAllBndrs [] thing_inside = thing_inside []+bindIfaceForAllBndrs (bndr:bndrs) thing_inside+  = bindIfaceForAllBndr bndr $ \tv vis ->+    bindIfaceForAllBndrs bndrs $ \bndrs' ->+    thing_inside (mkTyCoVarBinder vis tv : bndrs')++bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a+bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside+  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis+bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside+  = bindIfaceId tv $ \tv' -> thing_inside tv' vis++bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a+bindIfaceTyVar (occ,kind) thing_inside+  = do  { name <- newIfaceName (mkTyVarOccFS occ)+        ; tyvar <- mk_iface_tyvar name kind+        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }++bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a+bindIfaceTyVars [] thing_inside = thing_inside []+bindIfaceTyVars (bndr:bndrs) thing_inside+  = bindIfaceTyVar bndr   $ \tv  ->+    bindIfaceTyVars bndrs $ \tvs ->+    thing_inside (tv : tvs)++mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar+mk_iface_tyvar name ifKind+   = do { kind <- tcIfaceType ifKind+        ; return (Var.mkTyVar name kind) }++bindIfaceTyConBinders :: [IfaceTyConBinder]+                      -> ([TyConBinder] -> IfL a) -> IfL a+bindIfaceTyConBinders [] thing_inside = thing_inside []+bindIfaceTyConBinders (b:bs) thing_inside+  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->+    bindIfaceTyConBinders bs              $ \ bs' ->+    thing_inside (b':bs')++bindIfaceTyConBinders_AT :: [IfaceTyConBinder]+                         -> ([TyConBinder] -> IfL a) -> IfL a+-- Used for type variable in nested associated data/type declarations+-- where some of the type variables are already in scope+--    class C a where { data T a b }+-- Here 'a' is in scope when we look at the 'data T'+bindIfaceTyConBinders_AT [] thing_inside+  = thing_inside []+bindIfaceTyConBinders_AT (b : bs) thing_inside+  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->+    bindIfaceTyConBinders_AT      bs $ \bs' ->+    thing_inside (b':bs')+  where+    bind_tv tv thing+      = do { mb_tv <- lookupIfaceVar tv+           ; case mb_tv of+               Just b' -> thing b'+               Nothing -> bindIfaceBndr tv thing }++bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)+                      -> IfaceTyConBinder+                      -> (TyConBinder -> IfL a) -> IfL a+bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside+  = bind_tv tv $ \tv' ->+    thing_inside (Bndr tv' vis)
+ compiler/GHC/IfaceToCore.hs-boot view
@@ -0,0 +1,20 @@+module GHC.IfaceToCore where++import GhcPrelude+import GHC.Iface.Syntax+   ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule+   , IfaceAnnotation, IfaceCompleteMatch )+import TyCoRep     ( TyThing )+import TcRnTypes   ( IfL )+import InstEnv     ( ClsInst )+import FamInstEnv  ( FamInst )+import CoreSyn     ( CoreRule )+import HscTypes    ( CompleteMatch )+import Annotations ( Annotation )++tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing+tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]+tcIfaceInst         :: IfaceClsInst -> IfL ClsInst+tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst+tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
− compiler/GHC/Platform/ARM.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.ARM where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_arm 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/ARM64.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.ARM64 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_aarch64 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/NoRegs.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.NoRegs where--import GhcPrelude--#define MACHREGS_NO_REGS 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/PPC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.PPC where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_powerpc 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/Regs.hs 
@@ -1,113 +0,0 @@--module GHC.Platform.Regs-       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)-       where--import GhcPrelude--import CmmExpr-import GHC.Platform-import Reg--import qualified GHC.Platform.ARM        as ARM-import qualified GHC.Platform.ARM64      as ARM64-import qualified GHC.Platform.PPC        as PPC-import qualified GHC.Platform.S390X      as S390X-import qualified GHC.Platform.SPARC      as SPARC-import qualified GHC.Platform.X86        as X86-import qualified GHC.Platform.X86_64     as X86_64-import qualified GHC.Platform.NoRegs     as NoRegs---- | Returns 'True' if this global register is stored in a caller-saves--- machine register.--callerSaves :: Platform -> GlobalReg -> Bool-callerSaves platform- | platformUnregisterised platform = NoRegs.callerSaves- | otherwise- = case platformArch platform of-   ArchX86    -> X86.callerSaves-   ArchX86_64 -> X86_64.callerSaves-   ArchS390X  -> S390X.callerSaves-   ArchSPARC  -> SPARC.callerSaves-   ArchARM {} -> ARM.callerSaves-   ArchARM64  -> ARM64.callerSaves-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.callerSaves--    | otherwise -> NoRegs.callerSaves---- | Here is where the STG register map is defined for each target arch.--- The order matters (for the llvm backend anyway)! We must make sure to--- maintain the order here with the order used in the LLVM calling conventions.--- Note that also, this isn't all registers, just the ones that are currently--- possbily mapped to real registers.-activeStgRegs :: Platform -> [GlobalReg]-activeStgRegs platform- | platformUnregisterised platform = NoRegs.activeStgRegs- | otherwise- = case platformArch platform of-   ArchX86    -> X86.activeStgRegs-   ArchX86_64 -> X86_64.activeStgRegs-   ArchS390X  -> S390X.activeStgRegs-   ArchSPARC  -> SPARC.activeStgRegs-   ArchARM {} -> ARM.activeStgRegs-   ArchARM64  -> ARM64.activeStgRegs-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.activeStgRegs--    | otherwise -> NoRegs.activeStgRegs--haveRegBase :: Platform -> Bool-haveRegBase platform- | platformUnregisterised platform = NoRegs.haveRegBase- | otherwise- = case platformArch platform of-   ArchX86    -> X86.haveRegBase-   ArchX86_64 -> X86_64.haveRegBase-   ArchS390X  -> S390X.haveRegBase-   ArchSPARC  -> SPARC.haveRegBase-   ArchARM {} -> ARM.haveRegBase-   ArchARM64  -> ARM64.haveRegBase-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.haveRegBase--    | otherwise -> NoRegs.haveRegBase--globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg-globalRegMaybe platform- | platformUnregisterised platform = NoRegs.globalRegMaybe- | otherwise- = case platformArch platform of-   ArchX86    -> X86.globalRegMaybe-   ArchX86_64 -> X86_64.globalRegMaybe-   ArchS390X  -> S390X.globalRegMaybe-   ArchSPARC  -> SPARC.globalRegMaybe-   ArchARM {} -> ARM.globalRegMaybe-   ArchARM64  -> ARM64.globalRegMaybe-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.globalRegMaybe--    | otherwise -> NoRegs.globalRegMaybe--freeReg :: Platform -> RegNo -> Bool-freeReg platform- | platformUnregisterised platform = NoRegs.freeReg- | otherwise- = case platformArch platform of-   ArchX86    -> X86.freeReg-   ArchX86_64 -> X86_64.freeReg-   ArchS390X  -> S390X.freeReg-   ArchSPARC  -> SPARC.freeReg-   ArchARM {} -> ARM.freeReg-   ArchARM64  -> ARM64.freeReg-   arch-    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->-        PPC.freeReg--    | otherwise -> NoRegs.freeReg-
− compiler/GHC/Platform/S390X.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.S390X where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_s390x 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/SPARC.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.SPARC where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_sparc 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/X86.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.X86 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_i386 1-#include "../../../includes/CodeGen.Platform.hs"-
− compiler/GHC/Platform/X86_64.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE CPP #-}--module GHC.Platform.X86_64 where--import GhcPrelude--#define MACHREGS_NO_REGS 0-#define MACHREGS_x86_64 1-#include "../../../includes/CodeGen.Platform.hs"-
+ compiler/GHC/Rename/Binds.hs view
@@ -0,0 +1,1337 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Renaming and dependency analysis of bindings++This module does renaming and dependency analysis on value bindings in+the abstract syntax.  It does {\em not} do cycle-checks on class or+type-synonym declarations; those cannot be done at this stage because+they may be affected by renaming (which isn't fully worked out yet).+-}++module GHC.Rename.Binds (+   -- Renaming top-level bindings+   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,++   -- Renaming local bindings+   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,++   -- Other bindings+   rnMethodBinds, renameSigs,+   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,+   makeMiniFixityEnv, MiniFixityEnv,+   HsSigCtxt(..)+   ) where++import GhcPrelude++import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts )++import GHC.Hs+import TcRnMonad+import GHC.Rename.Types+import GHC.Rename.Pat+import GHC.Rename.Names+import GHC.Rename.Env+import GHC.Rename.Fixity+import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn+                        , checkDupRdrNames, warnUnusedLocalBinds+                        , checkUnusedRecordWildcard+                        , checkDupAndShadowedNames, bindLocalNamesFV )+import DynFlags+import Module+import Name+import NameEnv+import NameSet+import RdrName          ( RdrName, rdrNameOcc )+import SrcLoc+import ListSetOps       ( findDupsEq )+import BasicTypes       ( RecFlag(..), TypeOrKind(..) )+import Digraph          ( SCC(..) )+import Bag+import Util+import Outputable+import UniqSet+import Maybes           ( orElse )+import OrdList+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable      ( toList )+import Data.List          ( partition, sort )+import Data.List.NonEmpty ( NonEmpty(..) )++{-+-- ToDo: Put the annotations into the monad, so that they arrive in the proper+-- place and can be used when complaining.++The code tree received by the function @rnBinds@ contains definitions+in where-clauses which are all apparently mutually recursive, but which may+not really depend upon each other. For example, in the top level program+\begin{verbatim}+f x = y where a = x+              y = x+\end{verbatim}+the definitions of @a@ and @y@ do not depend on each other at all.+Unfortunately, the typechecker cannot always check such definitions.+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive+definitions. In Proceedings of the International Symposium on Programming,+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}+However, the typechecker usually can check definitions in which only the+strongly connected components have been collected into recursive bindings.+This is precisely what the function @rnBinds@ does.++ToDo: deal with case where a single monobinds binds the same variable+twice.++The vertag tag is a unique @Int@; the tags only need to be unique+within one @MonoBinds@, so that unique-Int plumbing is done explicitly+(heavy monad machinery not needed).+++************************************************************************+*                                                                      *+* naming conventions                                                   *+*                                                                      *+************************************************************************++\subsection[name-conventions]{Name conventions}++The basic algorithm involves walking over the tree and returning a tuple+containing the new tree plus its free variables. Some functions, such+as those walking polymorphic bindings (HsBinds) and qualifier lists in+list comprehensions (@Quals@), return the variables bound in local+environments. These are then used to calculate the free variables of the+expression evaluated in these environments.++Conventions for variable names are as follows:+\begin{itemize}+\item+new code is given a prime to distinguish it from the old.++\item+a set of variables defined in @Exp@ is written @dvExp@++\item+a set of variables free in @Exp@ is written @fvExp@+\end{itemize}++************************************************************************+*                                                                      *+* analysing polymorphic bindings (HsBindGroup, HsBind)+*                                                                      *+************************************************************************++\subsubsection[dep-HsBinds]{Polymorphic bindings}++Non-recursive expressions are reconstructed without any changes at top+level, although their component expressions may have to be altered.+However, non-recursive expressions are currently not expected as+\Haskell{} programs, and this code should not be executed.++Monomorphic bindings contain information that is returned in a tuple+(a @FlatMonoBinds@) containing:++\begin{enumerate}+\item+a unique @Int@ that serves as the ``vertex tag'' for this binding.++\item+the name of a function or the names in a pattern. These are a set+referred to as @dvLhs@, the defined variables of the left hand side.++\item+the free variables of the body. These are referred to as @fvBody@.++\item+the definition's actual code. This is referred to as just @code@.+\end{enumerate}++The function @nonRecDvFv@ returns two sets of variables. The first is+the set of variables defined in the set of monomorphic bindings, while the+second is the set of free variables in those bindings.++The set of variables defined in a non-recursive binding is just the+union of all of them, as @union@ removes duplicates. However, the+free variables in each successive set of cumulative bindings is the+union of those in the previous set plus those of the newest binding after+the defined variables of the previous set have been removed.++@rnMethodBinds@ deals only with the declarations in class and+instance declarations.  It expects only to see @FunMonoBind@s, and+it expects the global environment to contain bindings for the binders+(which are all class operations).++************************************************************************+*                                                                      *+\subsubsection{ Top-level bindings}+*                                                                      *+************************************************************************+-}++-- for top-level bindings, we need to make top-level names,+-- so we have a different entry point than for local bindings+rnTopBindsLHS :: MiniFixityEnv+              -> HsValBinds GhcPs+              -> RnM (HsValBindsLR GhcRn GhcPs)+rnTopBindsLHS fix_env binds+  = rnValBindsLHS (topRecNameMaker fix_env) binds++rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs+               -> RnM (HsValBinds GhcRn, DefUses)+-- A hs-boot file has no bindings.+-- Return a single HsBindGroup with empty binds and renamed signatures+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)+  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)+        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs+        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }+rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)++{-+*********************************************************+*                                                      *+                HsLocalBinds+*                                                      *+*********************************************************+-}++rnLocalBindsAndThen :: HsLocalBinds GhcPs+                   -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))+                   -> RnM (result, FreeVars)+-- This version (a) assumes that the binding vars are *not* already in scope+--               (b) removes the binders from the free vars of the thing inside+-- The parser doesn't produce ThenBinds+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =+  thing_inside (EmptyLocalBinds x) emptyNameSet++rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside+  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->+      thing_inside (HsValBinds x val_binds')++rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do+    (binds',fv_binds) <- rnIPBinds binds+    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds+    return (thing, fvs_thing `plusFV` fv_binds)++rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec++rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)+rnIPBinds (IPBinds _ ip_binds ) = do+    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds+    return (IPBinds noExtField ip_binds', plusFVs fvs_s)+rnIPBinds (XHsIPBinds nec) = noExtCon nec++rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)+rnIPBind (IPBind _ ~(Left n) expr) = do+    (expr',fvExpr) <- rnLExpr expr+    return (IPBind noExtField (Left n) expr', fvExpr)+rnIPBind (XIPBind nec) = noExtCon nec++{-+************************************************************************+*                                                                      *+                ValBinds+*                                                                      *+************************************************************************+-}++-- Renaming local binding groups+-- Does duplicate/shadow check+rnLocalValBindsLHS :: MiniFixityEnv+                   -> HsValBinds GhcPs+                   -> RnM ([Name], HsValBindsLR GhcRn GhcPs)+rnLocalValBindsLHS fix_env binds+  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds++         -- Check for duplicates and shadowing+         -- Must do this *after* renaming the patterns+         -- See Note [Collect binders only after renaming] in GHC.Hs.Utils++         -- We need to check for dups here because we+         -- don't don't bind all of the variables from the ValBinds at once+         -- with bindLocatedLocals any more.+         --+         -- Note that we don't want to do this at the top level, since+         -- sorting out duplicates and shadowing there happens elsewhere.+         -- The behavior is even different. For example,+         --   import A(f)+         --   f = ...+         -- should not produce a shadowing warning (but it will produce+         -- an ambiguity warning if you use f), but+         --   import A(f)+         --   g = let f = ... in f+         -- should.+       ; let bound_names = collectHsValBinders binds'+             -- There should be only Ids, but if there are any bogus+             -- pattern synonyms, we'll collect them anyway, so that+             -- we don't generate subsequent out-of-scope messages+       ; envs <- getRdrEnvs+       ; checkDupAndShadowedNames envs bound_names++       ; return (bound_names, binds') }++-- renames the left-hand sides+-- generic version used both at the top level and for local binds+-- does some error checking, but not what gets done elsewhere at the top level+rnValBindsLHS :: NameMaker+              -> HsValBinds GhcPs+              -> RnM (HsValBindsLR GhcRn GhcPs)+rnValBindsLHS topP (ValBinds x mbinds sigs)+  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds+       ; return $ ValBinds x mbinds' sigs }+  where+    bndrs = collectHsBindsBinders mbinds+    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs++rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)++-- General version used both from the top-level and for local things+-- Assumes the LHS vars are in scope+--+-- Does not bind the local fixity declarations+rnValBindsRHS :: HsSigCtxt+              -> HsValBindsLR GhcRn GhcPs+              -> RnM (HsValBinds GhcRn, DefUses)++rnValBindsRHS ctxt (ValBinds _ mbinds sigs)+  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs+       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds+       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus++       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $+                          getPatSynBinds anal_binds+                -- The uses in binds_w_dus for PatSynBinds do not include+                -- variables used in the patsyn builders; see+                -- Note [Pattern synonym builders don't yield dependencies]+                -- But psb_fvs /does/ include those builder fvs.  So we+                -- add them back in here to avoid bogus warnings about+                -- unused variables (#12548)++             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs+                                     `plusDU` usesOnly patsyn_fvs+                            -- Put the sig uses *after* the bindings+                            -- so that the binders are removed from+                            -- the uses in the sigs++        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }++rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)++-- Wrapper for local binds+--+-- The *client* of this function is responsible for checking for unused binders;+-- it doesn't (and can't: we don't have the thing inside the binds) happen here+--+-- The client is also responsible for bringing the fixities into scope+rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes+                   -> HsValBindsLR GhcRn GhcPs+                   -> RnM (HsValBinds GhcRn, DefUses)+rnLocalValBindsRHS bound_names binds+  = rnValBindsRHS (LocalBindCtxt bound_names) binds++-- for local binds+-- wrapper that does both the left- and right-hand sides+--+-- here there are no local fixity decls passed in;+-- the local fixity decls come from the ValBinds sigs+rnLocalValBindsAndThen+  :: HsValBinds GhcPs+  -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))+  -> RnM (result, FreeVars)+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside+ = do   {     -- (A) Create the local fixity environment+          new_fixities <- makeMiniFixityEnv [ L loc sig+                                            | L loc (FixSig _ sig) <- sigs]++              -- (B) Rename the LHSes+        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds++              --     ...and bring them (and their fixities) into scope+        ; bindLocalNamesFV bound_names              $+          addLocalFixities new_fixities bound_names $ do++        {      -- (C) Do the RHS and thing inside+          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs+        ; (result, result_fvs) <- thing_inside binds' (allUses dus)++                -- Report unused bindings based on the (accurate)+                -- findUses.  E.g.+                --      let x = x in 3+                -- should report 'x' unused+        ; let real_uses = findUses dus result_fvs+              -- Insert fake uses for variables introduced implicitly by+              -- wildcards (#4404)+              rec_uses = hsValBindsImplicits binds'+              implicit_uses = mkNameSet $ concatMap snd+                                        $ rec_uses+        ; mapM_ (\(loc, ns) ->+                    checkUnusedRecordWildcard loc real_uses (Just ns))+                rec_uses+        ; warnUnusedLocalBinds bound_names+                                      (real_uses `unionNameSet` implicit_uses)++        ; let+            -- The variables "used" in the val binds are:+            --   (1) the uses of the binds (allUses)+            --   (2) the FVs of the thing-inside+            all_uses = allUses dus `plusFV` result_fvs+                -- Note [Unused binding hack]+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~+                -- Note that *in contrast* to the above reporting of+                -- unused bindings, (1) above uses duUses to return *all*+                -- the uses, even if the binding is unused.  Otherwise consider:+                --      x = 3+                --      y = let p = x in 'x'    -- NB: p not used+                -- If we don't "see" the dependency of 'y' on 'x', we may put the+                -- bindings in the wrong order, and the type checker will complain+                -- that x isn't in scope+                --+                -- But note that this means we won't report 'x' as unused,+                -- whereas we would if we had { x = 3; p = x; y = 'x' }++        ; return (result, all_uses) }}+                -- The bound names are pruned out of all_uses+                -- by the bindLocalNamesFV call above++rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)+++---------------------++-- renaming a single bind++rnBindLHS :: NameMaker+          -> SDoc+          -> HsBind GhcPs+          -- returns the renamed left-hand side,+          -- and the FreeVars *of the LHS*+          -- (i.e., any free variables of the pattern)+          -> RnM (HsBindLR GhcRn GhcPs)++rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })+  = do+      -- we don't actually use the FV processing of rnPatsAndThen here+      (pat',pat'_fvs) <- rnBindPat name_maker pat+      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })+                -- We temporarily store the pat's FVs in bind_fvs;+                -- gets updated to the FVs of the whole bind+                -- when doing the RHS below++rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })+  = do { name <- applyNameMaker name_maker rdr_name+       ; return (bind { fun_id = name+                      , fun_ext = noExtField }) }++rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })+  | isTopRecNameMaker name_maker+  = do { addLocM checkConName rdrname+       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already+       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }++  | otherwise  -- Pattern synonym, not at top level+  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake+                                        -- name so that we can carry on+       ; name <- applyNameMaker name_maker rdrname+       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }+  where+    localPatternSynonymErr :: SDoc+    localPatternSynonymErr+      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))+           2 (text "Pattern synonym declarations are only valid at top level")++rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)++rnLBind :: (Name -> [Name])      -- Signature tyvar function+        -> LHsBindLR GhcRn GhcPs+        -> RnM (LHsBind GhcRn, [Name], Uses)+rnLBind sig_fn (L loc bind)+  = setSrcSpan loc $+    do { (bind', bndrs, dus) <- rnBind sig_fn bind+       ; return (L loc bind', bndrs, dus) }++-- assumes the left-hands-side vars are in scope+rnBind :: (Name -> [Name])        -- Signature tyvar function+       -> HsBindLR GhcRn GhcPs+       -> RnM (HsBind GhcRn, [Name], Uses)+rnBind _ bind@(PatBind { pat_lhs = pat+                       , pat_rhs = grhss+                                   -- pat fvs were stored in bind_fvs+                                   -- after processing the LHS+                       , pat_ext = pat_fvs })+  = do  { mod <- getModule+        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss++                -- No scoped type variables for pattern bindings+        ; let all_fvs = pat_fvs `plusFV` rhs_fvs+              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan+              bndrs = collectPatBinders pat+              bind' = bind { pat_rhs  = grhss'+                           , pat_ext = fvs' }++              ok_nobind_pat+                  = -- See Note [Pattern bindings that bind no variables]+                    case unLoc pat of+                       WildPat {}   -> True+                       BangPat {}   -> True -- #9127, #13646+                       SplicePat {} -> True+                       _            -> False++        -- Warn if the pattern binds no variables+        -- See Note [Pattern bindings that bind no variables]+        ; whenWOptM Opt_WarnUnusedPatternBinds $+          when (null bndrs && not ok_nobind_pat) $+          addWarn (Reason Opt_WarnUnusedPatternBinds) $+          unusedPatBindWarn bind'++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind', bndrs, all_fvs) }++rnBind sig_fn bind@(FunBind { fun_id = name+                            , fun_matches = matches })+       -- invariant: no free vars here when it's a FunBind+  = do  { let plain_name = unLoc name++        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $+                                -- bindSigTyVars tests for LangExt.ScopedTyVars+                                 rnMatchGroup (mkPrefixFunRhs name)+                                              rnLExpr matches+        ; let is_infix = isInfixFunBind bind+        ; when is_infix $ checkPrecMatch plain_name matches'++        ; mod <- getModule+        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind { fun_matches = matches'+                       , fun_ext     = fvs' },+                  [plain_name], rhs_fvs)+      }++rnBind sig_fn (PatSynBind x bind)+  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind+        ; return (PatSynBind x bind', name, fvs) }++rnBind _ b = pprPanic "rnBind" (ppr b)++{- Note [Pattern bindings that bind no variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally, we want to warn about pattern bindings like+  Just _ = e+because they don't do anything!  But we have three exceptions:++* A wildcard pattern+       _ = rhs+  which (a) is not that different from  _v = rhs+        (b) is sometimes used to give a type sig for,+            or an occurrence of, a variable on the RHS++* A strict pattern binding; that is, one with an outermost bang+     !Just _ = e+  This can fail, so unlike the lazy variant, it is not a no-op.+  Moreover, #13646 argues that even for single constructor+  types, you might want to write the constructor.  See also #9127.++* A splice pattern+      $(th-lhs) = rhs+   It is impossible to determine whether or not th-lhs really+   binds any variable. We should disable the warning for any pattern+   which contain splices, but that is a more expensive check.++Note [Free-variable space leak]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have+    fvs' = trim fvs+and we seq fvs' before turning it as part of a record.++The reason is that trim is sometimes something like+    \xs -> intersectNameSet (mkNameSet bound_names) xs+and we don't want to retain the list bound_names. This showed up in+trac ticket #1136.+-}++{- *********************************************************************+*                                                                      *+          Dependency analysis and other support functions+*                                                                      *+********************************************************************* -}++depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)+             -> ([(RecFlag, LHsBinds GhcRn)], DefUses)+-- Dependency analysis; this is important so that+-- unused-binding reporting is accurate+depAnalBinds binds_w_dus+  = (map get_binds sccs, toOL $ map get_du sccs)+  where+    sccs = depAnal (\(_, defs, _) -> defs)+                   (\(_, _, uses) -> nonDetEltsUniqSet uses)+                   -- It's OK to use nonDetEltsUniqSet here as explained in+                   -- Note [depAnal determinism] in NameEnv.+                   (bagToList binds_w_dus)++    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])++    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)+    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)+        where+          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]+          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]++---------------------+-- Bind the top-level forall'd type variables in the sigs.+-- E.g  f :: forall a. a -> a+--      f = rhs+--      The 'a' scopes over the rhs+--+-- NB: there'll usually be just one (for a function binding)+--     but if there are many, one may shadow the rest; too bad!+--      e.g  x :: forall a. [a] -> [a]+--           y :: forall a. [(a,a)] -> a+--           (x,y) = e+--      In e, 'a' will be in scope, and it'll be the one from 'y'!++mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])+-- Return a lookup function that maps an Id Name to the names+-- of the type variables that should scope over its body.+mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []+  where+    env = mkHsSigEnv get_scoped_tvs sigs++    get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])+    -- Returns (binders, scoped tvs for those binders)+    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))+      = Just (names, hsScopedTvs sig_ty)+    get_scoped_tvs (L _ (TypeSig _ names sig_ty))+      = Just (names, hsWcScopedTvs sig_ty)+    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))+      = Just (names, hsScopedTvs sig_ty)+    get_scoped_tvs _ = Nothing++-- Process the fixity declarations, making a FastString -> (Located Fixity) map+-- (We keep the location around for reporting duplicate fixity declarations.)+--+-- Checks for duplicates, but not that only locally defined things are fixed.+-- Note: for local fixity declarations, duplicates would also be checked in+--       check_sigs below.  But we also use this function at the top level.++makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv++makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls+ where+   add_one_sig env (L loc (FixitySig _ names fixity)) =+     foldlM add_one env [ (loc,name_loc,name,fixity)+                        | L name_loc name <- names ]+   add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec++   add_one env (loc, name_loc, name,fixity) = do+     { -- this fixity decl is a duplicate iff+       -- the ReaderName's OccName's FastString is already in the env+       -- (we only need to check the local fix_env because+       --  definitions of non-local will be caught elsewhere)+       let { fs = occNameFS (rdrNameOcc name)+           ; fix_item = L loc fixity };++       case lookupFsEnv env fs of+         Nothing -> return $ extendFsEnv env fs fix_item+         Just (L loc' _) -> do+           { setSrcSpan loc $+             addErrAt name_loc (dupFixityDecl loc' name)+           ; return env}+     }++dupFixityDecl :: SrcSpan -> RdrName -> SDoc+dupFixityDecl loc rdr_name+  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+          text "also at " <+> ppr loc]+++{- *********************************************************************+*                                                                      *+                Pattern synonym bindings+*                                                                      *+********************************************************************* -}++rnPatSynBind :: (Name -> [Name])           -- Signature tyvar function+             -> PatSynBind GhcRn GhcPs+             -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)+rnPatSynBind sig_fn bind@(PSB { psb_id = L l name+                              , psb_args = details+                              , psb_def = pat+                              , psb_dir = dir })+       -- invariant: no free vars here when it's a FunBind+  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms+        ; unless pattern_synonym_ok (addErr patternSynonymErr)+        ; let scoped_tvs = sig_fn name++        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $+                                      rnPat PatSyn pat $ \pat' ->+         -- We check the 'RdrName's instead of the 'Name's+         -- so that the binding locations are reported+         -- from the left-hand side+            case details of+               PrefixCon vars ->+                   do { checkDupRdrNames vars+                      ; names <- mapM lookupPatSynBndr vars+                      ; return ( (pat', PrefixCon names)+                               , mkFVs (map unLoc names)) }+               InfixCon var1 var2 ->+                   do { checkDupRdrNames [var1, var2]+                      ; name1 <- lookupPatSynBndr var1+                      ; name2 <- lookupPatSynBndr var2+                      -- ; checkPrecMatch -- TODO+                      ; return ( (pat', InfixCon name1 name2)+                               , mkFVs (map unLoc [name1, name2])) }+               RecCon vars ->+                   do { checkDupRdrNames (map recordPatSynSelectorId vars)+                      ; let rnRecordPatSynField+                              (RecordPatSynField { recordPatSynSelectorId = visible+                                                 , recordPatSynPatVar = hidden })+                              = do { visible' <- lookupLocatedTopBndrRn visible+                                   ; hidden'  <- lookupPatSynBndr hidden+                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'+                                                                , recordPatSynPatVar = hidden' } }+                      ; names <- mapM rnRecordPatSynField  vars+                      ; return ( (pat', RecCon names)+                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }++        ; (dir', fvs2) <- case dir of+            Unidirectional -> return (Unidirectional, emptyFVs)+            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)+            ExplicitBidirectional mg ->+                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $+                                   rnMatchGroup (mkPrefixFunRhs (L l name))+                                                rnLExpr mg+                   ; return (ExplicitBidirectional mg', fvs) }++        ; mod <- getModule+        ; let fvs = fvs1 `plusFV` fvs2+              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan++              bind' = bind{ psb_args = details'+                          , psb_def = pat'+                          , psb_dir = dir'+                          , psb_ext = fvs' }+              selector_names = case details' of+                                 RecCon names ->+                                  map (unLoc . recordPatSynSelectorId) names+                                 _ -> []++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind', name : selector_names , fvs1)+          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]+      }+  where+    -- See Note [Renaming pattern synonym variables]+    lookupPatSynBndr = wrapLocM lookupLocalOccRn++    patternSynonymErr :: SDoc+    patternSynonymErr+      = hang (text "Illegal pattern synonym declaration")+           2 (text "Use -XPatternSynonyms to enable this extension")++rnPatSynBind _ (XPatSynBind nec) = noExtCon nec++{-+Note [Renaming pattern synonym variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We rename pattern synonym declaractions backwards to normal to reuse+the logic already implemented for renaming patterns.++We first rename the RHS of a declaration which brings into+scope the variables bound by the pattern (as they would be+in normal function definitions). We then lookup the variables+which we want to bind in this local environment.++It is crucial that we then only lookup in the *local* environment which+only contains the variables brought into scope by the pattern and nothing+else. Amazingly no-one encountered this bug for 3 GHC versions but+it was possible to define a pattern synonym which referenced global+identifiers and worked correctly.++```+x = 5++pattern P :: Int -> ()+pattern P x <- _++f (P x) = x++> f () = 5+```++See #13470 for the original report.++Note [Pattern synonym builders don't yield dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a pattern synonym that has an explicit builder,+references in the builder definition should not be used when+calculating dependencies. For example, consider the following pattern+synonym definition:++pattern P x <- C1 x where+  P x = f (C1 x)++f (P x) = C2 x++In this case, 'P' needs to be typechecked in two passes:++1. Typecheck the pattern definition of 'P', which fully determines the+   type of 'P'. This step doesn't require knowing anything about 'f',+   since the builder definition is not looked at.++2. Typecheck the builder definition, which needs the typechecked+   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind+   in TcBinds.tcValBinds.++This behaviour is implemented in 'tcValBinds', but it crucially+depends on 'P' not being put in a recursive group with 'f' (which+would make it look like a recursive pattern synonym a la 'pattern P =+P' which is unsound and rejected).++So:+ * We do not include builder fvs in the Uses returned by rnPatSynBind+   (which is then used for dependency analysis)+ * But we /do/ include them in the psb_fvs for the PatSynBind+ * In rnValBinds we record these builder uses, to avoid bogus+   unused-variable warnings (#12548)+-}++{- *********************************************************************+*                                                                      *+                Class/instance method bindings+*                                                                      *+********************************************************************* -}++{- @rnMethodBinds@ is used for the method bindings of a class and an instance+declaration.   Like @rnBinds@ but without dependency analysis.++NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.+That's crucial when dealing with an instance decl:+\begin{verbatim}+        instance Foo (T a) where+           op x = ...+\end{verbatim}+This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,+and unless @op@ occurs we won't treat the type signature of @op@ in the class+decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,+in many ways the @op@ in an instance decl is just like an occurrence, not+a binder.+-}++rnMethodBinds :: Bool                   -- True <=> is a class declaration+              -> Name                   -- Class name+              -> [Name]                 -- Type variables from the class/instance header+              -> LHsBinds GhcPs         -- Binds+              -> [LSig GhcPs]           -- and signatures/pragmas+              -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)+-- Used for+--   * the default method bindings in a class decl+--   * the method bindings in an instance decl+rnMethodBinds is_cls_decl cls ktv_names binds sigs+  = do { checkDupRdrNames (collectMethodBinders binds)+             -- Check that the same method is not given twice in the+             -- same instance decl      instance C T where+             --                       f x = ...+             --                       g y = ...+             --                       f x = ...+             -- We must use checkDupRdrNames because the Name of the+             -- method is the Name of the class selector, whose SrcSpan+             -- points to the class declaration; and we use rnMethodBinds+             -- for instance decls too++       -- Rename the bindings LHSs+       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds++       -- Rename the pragmas and signatures+       -- Annoyingly the type variables /are/ in scope for signatures, but+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.+       --    instance Eq a => Eq (T a) where+       --       (==) :: a -> a -> a+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs+             bound_nms = mkNameSet (collectHsBindsBinders binds')+             sig_ctxt | is_cls_decl = ClsDeclCtxt cls+                      | otherwise   = InstDeclCtxt bound_nms+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags+       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $+                                        renameSigs sig_ctxt other_sigs++       -- Rename the bindings RHSs.  Again there's an issue about whether the+       -- type variables from the class/instance head are in scope.+       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables+       ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables+       ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $+              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'+                 ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)+                                           emptyFVs binds_w_dus+                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }++       ; return ( binds'', spec_inst_prags' ++ other_sigs'+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }+  where+    -- For the method bindings in class and instance decls, we extend+    -- the type variable environment iff -XScopedTypeVariables+    maybe_extend_tyvar_env scoped_tvs thing_inside+       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside+       | otherwise  = thing_inside++rnMethodBindLHS :: Bool -> Name+                -> LHsBindLR GhcPs GhcPs+                -> LHsBindsLR GhcRn GhcPs+                -> RnM (LHsBindsLR GhcRn GhcPs)+rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest+  = setSrcSpan loc $ do+    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name+                     -- We use the selector name as the binder+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }+       ; return (L loc bind' `consBag` rest ) }++-- Report error for all other forms of bindings+-- This is why we use a fold rather than map+rnMethodBindLHS is_cls_decl _ (L loc bind) rest+  = do { addErrAt loc $+         vcat [ what <+> text "not allowed in" <+> decl_sort+              , nest 2 (ppr bind) ]+       ; return rest }+  where+    decl_sort | is_cls_decl = text "class declaration:"+              | otherwise   = text "instance declaration:"+    what = case bind of+              PatBind {}    -> text "Pattern bindings (except simple variables)"+              PatSynBind {} -> text "Pattern synonyms"+                               -- Associated pattern synonyms are not implemented yet+              _ -> pprPanic "rnMethodBind" (ppr bind)++{-+************************************************************************+*                                                                      *+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}+*                                                                      *+************************************************************************++@renameSigs@ checks for:+\begin{enumerate}+\item more than one sig for one thing;+\item signatures given for things not bound here;+\end{enumerate}++At the moment we don't gather free-var info from the types in+signatures.  We'd only need this if we wanted to report unused tyvars.+-}++renameSigs :: HsSigCtxt+           -> [LSig GhcPs]+           -> RnM ([LSig GhcRn], FreeVars)+-- Renames the signatures and performs error checks+renameSigs ctxt sigs+  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)++        ; checkDupMinimalSigs sigs++        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs++        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'+        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced++        ; return (good_sigs, sig_fvs) }++----------------------+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory+-- because this won't work for:+--      instance Foo T where+--        {-# INLINE op #-}+--        Baz.op = ...+-- We'll just rename the INLINE prag to refer to whatever other 'op'+-- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)+-- Doesn't seem worth much trouble to sort this.++renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)+renameSig _ (IdSig _ x)+  = return (IdSig noExtField x, emptyFVs)    -- Actually this never occurs++renameSig ctxt sig@(TypeSig _ vs ty)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)+        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty+        ; return (TypeSig noExtField new_vs new_ty, fvs) }++renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)+  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures+        ; when (is_deflt && not defaultSigs_on) $+          addErr (defaultSigErr sig)+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty+        ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }+  where+    (v1:_) = vs+    ty_ctxt = GenericCtx (text "a class method signature for"+                          <+> quotes (ppr v1))++renameSig _ (SpecInstSig _ src ty)+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty+        ; return (SpecInstSig noExtField src new_ty,fvs) }++-- {-# SPECIALISE #-} pragmas can refer to imported Ids+-- so, in the top-level case (when mb_names is Nothing)+-- we use lookupOccRn.  If there's both an imported and a local 'f'+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures+renameSig ctxt sig@(SpecSig _ v tys inl)+  = do  { new_v <- case ctxt of+                     TopSigCtxt {} -> lookupLocatedOccRn v+                     _             -> lookupSigOccRn ctxt sig v+        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys+        ; return (SpecSig noExtField new_v new_ty inl, fvs) }+  where+    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"+                          <+> quotes (ppr v))+    do_one (tys,fvs) ty+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty+           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }++renameSig ctxt sig@(InlineSig _ v s)+  = do  { new_v <- lookupSigOccRn ctxt sig v+        ; return (InlineSig noExtField new_v s, emptyFVs) }++renameSig ctxt (FixSig _ fsig)+  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig+        ; return (FixSig noExtField new_fsig, emptyFVs) }++renameSig ctxt sig@(MinimalSig _ s (L l bf))+  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf+       return (MinimalSig noExtField s (L l new_bf), emptyFVs)++renameSig ctxt sig@(PatSynSig _ vs ty)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty+        ; return (PatSynSig noExtField new_vs ty', fvs) }+  where+    ty_ctxt = GenericCtx (text "a pattern synonym signature for"+                          <+> ppr_sig_bndrs vs)++renameSig ctxt sig@(SCCFunSig _ st v s)+  = do  { new_v <- lookupSigOccRn ctxt sig v+        ; return (SCCFunSig noExtField st new_v s, emptyFVs) }++-- COMPLETE Sigs can refer to imported IDs which is why we use+-- lookupLocatedOccRn rather than lookupSigOccRn+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)+  = do new_bf <- traverse lookupLocatedOccRn bf+       new_mty  <- traverse lookupLocatedOccRn mty++       this_mod <- fmap tcg_mod getGblEnv+       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do+         -- Why 'any'? See Note [Orphan COMPLETE pragmas]+         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError++       return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs)+  where+    orphanError :: SDoc+    orphanError =+      text "Orphan COMPLETE pragmas not supported" $$+      text "A COMPLETE pragma must mention at least one data constructor" $$+      text "or pattern synonym defined in the same module."++renameSig _ (XSig nec) = noExtCon nec++{-+Note [Orphan COMPLETE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We define a COMPLETE pragma to be a non-orphan if it includes at least+one conlike defined in the current module. Why is this sufficient?+Well if you have a pattern match++  case expr of+    P1 -> ...+    P2 -> ...+    P3 -> ...++any COMPLETE pragma which mentions a conlike other than P1, P2 or P3+will not be of any use in verifying that the pattern match is+exhaustive. So as we have certainly read the interface files that+define P1, P2 and P3, we will have loaded all non-orphan COMPLETE+pragmas that could be relevant to this pattern match.++For now we simply disallow orphan COMPLETE pragmas, as the added+complexity of supporting them properly doesn't seem worthwhile.+-}++ppr_sig_bndrs :: [Located RdrName] -> SDoc+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)++okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool+okHsSig ctxt (L _ sig)+  = case (sig, ctxt) of+     (ClassOpSig {}, ClsDeclCtxt {})  -> True+     (ClassOpSig {}, InstDeclCtxt {}) -> True+     (ClassOpSig {}, _)               -> False++     (TypeSig {}, ClsDeclCtxt {})  -> False+     (TypeSig {}, InstDeclCtxt {}) -> False+     (TypeSig {}, _)               -> True++     (PatSynSig {}, TopSigCtxt{}) -> True+     (PatSynSig {}, _)            -> False++     (FixSig {}, InstDeclCtxt {}) -> False+     (FixSig {}, _)               -> True++     (IdSig {}, TopSigCtxt {})   -> True+     (IdSig {}, InstDeclCtxt {}) -> True+     (IdSig {}, _)               -> False++     (InlineSig {}, HsBootCtxt {}) -> False+     (InlineSig {}, _)             -> True++     (SpecSig {}, TopSigCtxt {})    -> True+     (SpecSig {}, LocalBindCtxt {}) -> True+     (SpecSig {}, InstDeclCtxt {})  -> True+     (SpecSig {}, _)                -> False++     (SpecInstSig {}, InstDeclCtxt {}) -> True+     (SpecInstSig {}, _)               -> False++     (MinimalSig {}, ClsDeclCtxt {}) -> True+     (MinimalSig {}, _)              -> False++     (SCCFunSig {}, HsBootCtxt {}) -> False+     (SCCFunSig {}, _)             -> True++     (CompleteMatchSig {}, TopSigCtxt {} ) -> True+     (CompleteMatchSig {}, _)              -> False++     (XSig nec, _) -> noExtCon nec++-------------------+findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]+-- Check for duplicates on RdrName version,+-- because renamed version has unboundName for+-- not-in-scope binders, which gives bogus dup-sig errors+-- NB: in a class decl, a 'generic' sig is not considered+--     equal to an ordinary sig, so we allow, say+--           class C a where+--             op :: a -> a+--             default op :: Eq a => a -> a+findDupSigs sigs+  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)+  where+    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)+    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]+    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]+    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]+    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]+    expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]+    expand_sig _ = []++    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2+    mtch (FixSig {})           (FixSig {})         = True+    mtch (InlineSig {})        (InlineSig {})      = True+    mtch (TypeSig {})          (TypeSig {})        = True+    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2+    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True+    mtch (SCCFunSig{})         (SCCFunSig{})       = True+    mtch _ _ = False++-- Warn about multiple MINIMAL signatures+checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()+checkDupMinimalSigs sigs+  = case filter isMinimalLSig sigs of+      minSigs@(_:_:_) -> dupMinimalSigErr minSigs+      _ -> return ()++{-+************************************************************************+*                                                                      *+\subsection{Match}+*                                                                      *+************************************************************************+-}++rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name+             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+             -> MatchGroup GhcPs (Located (body GhcPs))+             -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)+rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })+  = do { empty_case_ok <- xoptM LangExt.EmptyCase+       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))+       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms+       ; return (mkMatchGroup origin new_ms, ms_fvs) }+rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec++rnMatch :: Outputable (body GhcPs) => HsMatchContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> LMatch GhcPs (Located (body GhcPs))+        -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)+rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)++rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name+         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+         -> Match GhcPs (Located (body GhcPs))+         -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })+  = do  { -- Note that there are no local fixity decls for matches+        ; rnPats ctxt pats      $ \ pats' -> do+        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss+        ; let mf' = case (ctxt, mf) of+                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })+                                            -> mf { mc_fun = L lf funid }+                      _                     -> ctxt+        ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats'+                        , m_grhss = grhss'}, grhss_fvs ) }}+rnMatch' _ _ (XMatch nec) = noExtCon nec++emptyCaseErr :: HsMatchContext Name -> SDoc+emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)+                       2 (text "Use EmptyCase to allow this")+  where+    pp_ctxt = case ctxt of+                CaseAlt    -> text "case expression"+                LambdaExpr -> text "\\case expression"+                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt++{-+************************************************************************+*                                                                      *+\subsubsection{Guarded right-hand sides (GRHSs)}+*                                                                      *+************************************************************************+-}++rnGRHSs :: HsMatchContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> GRHSs GhcPs (Located (body GhcPs))+        -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))+  = rnLocalBindsAndThen binds   $ \ binds' _ -> do+    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss+    return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)+rnGRHSs _ _ (XGRHSs nec) = noExtCon nec++rnGRHS :: HsMatchContext Name+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+       -> LGRHS GhcPs (Located (body GhcPs))+       -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)+rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)++rnGRHS' :: HsMatchContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> GRHS GhcPs (Located (body GhcPs))+        -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)+rnGRHS' ctxt rnBody (GRHS _ guards rhs)+  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards+        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->+                                    rnBody rhs++        ; unless (pattern_guards_allowed || is_standard_guard guards')+                 (addWarn NoReason (nonStdGuardErr guards'))++        ; return (GRHS noExtField guards' rhs', fvs) }+  where+        -- Standard Haskell 1.4 guards are just a single boolean+        -- expression, rather than a list of qualifiers as in the+        -- Glasgow extension+    is_standard_guard []                  = True+    is_standard_guard [L _ (BodyStmt {})] = True+    is_standard_guard _                   = False+rnGRHS' _ _ (XGRHS nec) = noExtCon nec++{-+*********************************************************+*                                                       *+        Source-code fixity declarations+*                                                       *+*********************************************************+-}++rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)+-- Rename a fixity decl, so we can put+-- the renamed decl in the renamed syntax tree+-- Errors if the thing being fixed is not defined locally.+rnSrcFixityDecl sig_ctxt = rn_decl+  where+    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)+        -- GHC extension: look up both the tycon and data con+        -- for con-like things; hence returning a list+        -- If neither are in scope, report an error; otherwise+        -- return a fixity sig for each (slightly odd)+    rn_decl (FixitySig _ fnames fixity)+      = do names <- concatMapM lookup_one fnames+           return (FixitySig noExtField names fixity)+    rn_decl (XFixitySig nec) = noExtCon nec++    lookup_one :: Located RdrName -> RnM [Located Name]+    lookup_one (L name_loc rdr_name)+      = setSrcSpan name_loc $+                    -- This lookup will fail if the name is not defined in the+                    -- same binding group as this fixity declaration.+        do names <- lookupLocalTcNames sig_ctxt what rdr_name+           return [ L name_loc name | (_, name) <- names ]+    what = text "fixity signature"++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()+dupSigDeclErr pairs@((L loc name, sig) :| _)+  = addErrAt loc $+    vcat [ text "Duplicate" <+> what_it_is+           <> text "s for" <+> quotes (ppr name)+         , text "at" <+> vcat (map ppr $ sort+                                       $ map (getLoc . fst)+                                       $ toList pairs)+         ]+  where+    what_it_is = hsSigDoc sig++misplacedSigErr :: LSig GhcRn -> RnM ()+misplacedSigErr (L loc sig)+  = addErrAt loc $+    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]++defaultSigErr :: Sig GhcPs -> SDoc+defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")+                              2 (ppr sig)+                         , text "Use DefaultSignatures to enable default signatures" ]++bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc+bindsInHsBootFile mbinds+  = hang (text "Bindings in hs-boot files are not allowed")+       2 (ppr mbinds)++nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc+nonStdGuardErr guards+  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")+       4 (interpp'SP guards)++unusedPatBindWarn :: HsBind GhcRn -> SDoc+unusedPatBindWarn bind+  = hang (text "This pattern-binding binds no variables:")+       2 (ppr bind)++dupMinimalSigErr :: [LSig GhcPs] -> RnM ()+dupMinimalSigErr sigs@(L loc _ : _)+  = addErrAt loc $+    vcat [ text "Multiple minimal complete definitions"+         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)+         , text "Combine alternative minimal complete definitions with `|'" ]+dupMinimalSigErr [] = panic "dupMinimalSigErr"
+ compiler/GHC/Rename/Doc.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ViewPatterns #-}++module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where++import GhcPrelude++import TcRnTypes+import GHC.Hs+import SrcLoc+++rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)+rnMbLHsDoc mb_doc = case mb_doc of+  Just doc -> do+    doc' <- rnLHsDoc doc+    return (Just doc')+  Nothing -> return Nothing++rnLHsDoc :: LHsDocString -> RnM LHsDocString+rnLHsDoc (L pos doc) = do+  doc' <- rnHsDoc doc+  return (L pos doc')++rnHsDoc :: HsDocString -> RnM HsDocString+rnHsDoc = pure
+ compiler/GHC/Rename/Env.hs view
@@ -0,0 +1,1702 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-2006++GHC.Rename.Env contains functions which convert RdrNames into Names.++-}++{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}++module GHC.Rename.Env (+        newTopSrcBinder,+        lookupLocatedTopBndrRn, lookupTopBndrRn,+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,+        lookupLocalOccRn_maybe, lookupInfoOccRn,+        lookupLocalOccThLvl_maybe, lookupLocalOccRn,+        lookupTypeOccRn,+        lookupGlobalOccRn, lookupGlobalOccRn_maybe,+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,++        ChildLookupResult(..),+        lookupSubBndrOcc_helper,+        combineChildLookupResult, -- Called by lookupChildrenExport++        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,+        lookupSigCtxtOccRn,++        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,+        lookupConstructorFields,++        lookupGreAvailRn,++        -- Rebindable Syntax+        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,+        lookupIfThenElse,++        -- Constructing usage information+        addUsedGRE, addUsedGREs, addUsedDataCons,++++        dataTcOccs, --TODO: Move this somewhere, into utils?++    ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Iface.Load   ( loadInterfaceForName, loadSrcInterface_maybe )+import GHC.Iface.Env+import GHC.Hs+import RdrName+import HscTypes+import TcEnv+import TcRnMonad+import RdrHsSyn         ( filterCTuple, setRdrNameSpace )+import TysWiredIn+import Name+import NameSet+import NameEnv+import Avail+import Module+import ConLike+import DataCon+import TyCon+import ErrUtils         ( MsgDoc )+import PrelNames        ( rOOT_MAIN )+import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))+import SrcLoc+import Outputable+import UniqSet          ( uniqSetAny )+import Util+import Maybes+import DynFlags+import FastString+import Control.Monad+import ListSetOps       ( minusList )+import qualified GHC.LanguageExtensions as LangExt+import GHC.Rename.Unbound+import GHC.Rename.Utils+import qualified Data.Semigroup as Semi+import Data.Either      ( partitionEithers )+import Data.List        (find)++{-+*********************************************************+*                                                      *+                Source-code binders+*                                                      *+*********************************************************++Note [Signature lazy interface loading]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GHC's lazy interface loading can be a bit confusing, so this Note is an+empirical description of what happens in one interesting case. When+compiling a signature module against an its implementation, we do NOT+load interface files associated with its names until after the type+checking phase.  For example:++    module ASig where+        data T+        f :: T -> T++Suppose we compile this with -sig-of "A is ASig":++    module B where+        data T = T+        f T = T++    module A(module B) where+        import B++During type checking, we'll load A.hi because we need to know what the+RdrEnv for the module is, but we DO NOT load the interface for B.hi!+It's wholly unnecessary: our local definition 'data T' in ASig is all+the information we need to finish type checking.  This is contrast to+type checking of ordinary Haskell files, in which we would not have the+local definition "data T" and would need to consult B.hi immediately.+(Also, this situation never occurs for hs-boot files, since you're not+allowed to reexport from another module.)++After type checking, we then check that the types we provided are+consistent with the backing implementation (in checkHiBootOrHsigIface).+At this point, B.hi is loaded, because we need something to compare+against.++I discovered this behavior when trying to figure out why type class+instances for Data.Map weren't in the EPS when I was type checking a+test very much like ASig (sigof02dm): the associated interface hadn't+been loaded yet!  (The larger issue is a moot point, since an instance+declared in a signature can never be a duplicate.)++This behavior might change in the future.  Consider this+alternate module B:++    module B where+        {-# DEPRECATED T, f "Don't use" #-}+        data T = T+        f T = T++One might conceivably want to report deprecation warnings when compiling+ASig with -sig-of B, in which case we need to look at B.hi to find the+deprecation warnings during renaming.  At the moment, you don't get any+warning until you use the identifier further downstream.  This would+require adjusting addUsedGRE so that during signature compilation,+we do not report deprecation warnings for LocalDef.  See also+Note [Handling of deprecations]+-}++newTopSrcBinder :: Located RdrName -> RnM Name+newTopSrcBinder (L loc rdr_name)+  | Just name <- isExact_maybe rdr_name+  =     -- This is here to catch+        --   (a) Exact-name binders created by Template Haskell+        --   (b) The PrelBase defn of (say) [] and similar, for which+        --       the parser reads the special syntax and returns an Exact RdrName+        -- We are at a binding site for the name, so check first that it+        -- the current module is the correct one; otherwise GHC can get+        -- very confused indeed. This test rejects code like+        --      data T = (,) Int Int+        -- unless we are in GHC.Tup+    if isExternalName name then+      do { this_mod <- getModule+         ; unless (this_mod == nameModule name)+                  (addErrAt loc (badOrigBinding rdr_name))+         ; return name }+    else   -- See Note [Binders in Template Haskell] in Convert.hs+      do { this_mod <- getModule+         ; externaliseName this_mod name }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do  { this_mod <- getModule+        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)+                 (addErrAt loc (badOrigBinding rdr_name))+        -- When reading External Core we get Orig names as binders,+        -- but they should agree with the module gotten from the monad+        --+        -- We can get built-in syntax showing up here too, sadly.  If you type+        --      data T = (,,,)+        -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon+        -- uses setRdrNameSpace to make it into a data constructors.  At that point+        -- the nice Exact name for the TyCon gets swizzled to an Orig name.+        -- Hence the badOrigBinding error message.+        --+        -- Except for the ":Main.main = ..." definition inserted into+        -- the Main module; ugh!++        -- Because of this latter case, we call newGlobalBinder with a module from+        -- the RdrName, not from the environment.  In principle, it'd be fine to+        -- have an arbitrary mixture of external core definitions in a single module,+        -- (apart from module-initialisation issues, perhaps).+        ; newGlobalBinder rdr_mod rdr_occ loc }++  | otherwise+  = do  { when (isQual rdr_name)+                 (addErrAt loc (badQualBndrErr rdr_name))+                -- Binders should not be qualified; if they are, and with a different+                -- module name, we get a confusing "M.T is not in scope" error later++        ; stage <- getStage+        ; if isBrackStage stage then+                -- We are inside a TH bracket, so make an *Internal* name+                -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names+             do { uniq <- newUnique+                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }+          else+             do { this_mod <- getModule+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }+        }++{-+*********************************************************+*                                                      *+        Source code occurrences+*                                                      *+*********************************************************++Looking up a name in the GHC.Rename.Env.++Note [Type and class operator definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to reject all of these unless we have -XTypeOperators (#3265)+   data a :*: b  = ...+   class a :*: b where ...+   data (:*:) a b  = ....+   class (:*:) a b where ...+The latter two mean that we are not just looking for a+*syntactically-infix* declaration, but one that uses an operator+OccName.  We use OccName.isSymOcc to detect that case, which isn't+terribly efficient, but there seems to be no better way.+-}++-- Can be made to not be exposed+-- Only used unwrapped in rnAnnProvenance+lookupTopBndrRn :: RdrName -> RnM Name+lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n+                       case nopt of+                         Just n' -> return n'+                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)+                                       unboundName WL_LocalTop n++lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn++lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)+-- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',+-- and there may be several imported 'f's too, which must not confuse us.+-- For example, this is OK:+--      import Foo( f )+--      infix 9 f       -- The 'f' here does not need to be qualified+--      f x = x         -- Nor here, of course+-- So we have to filter out the non-local ones.+--+-- A separate function (importsFromLocalDecls) reports duplicate top level+-- decls, so here it's safe just to choose an arbitrary one.+--+-- There should never be a qualified name in a binding position in Haskell,+-- but there can be if we have read in an external-Core file.+-- The Haskell parser checks for the illegal qualified name in Haskell+-- source files, so we don't need to do so here.++lookupTopBndrRn_maybe rdr_name =+  lookupExactOrOrig rdr_name Just $+    do  {  -- Check for operators in type or class declarations+           -- See Note [Type and class operator definitions]+          let occ = rdrNameOcc rdr_name+        ; when (isTcOcc occ && isSymOcc occ)+               (do { op_ok <- xoptM LangExt.TypeOperators+                   ; unless op_ok (addErr (opDeclErr rdr_name)) })++        ; env <- getGlobalRdrEnv+        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of+            [gre] -> return (Just (gre_name gre))+            _     -> return Nothing  -- Ambiguous (can't happen) or unbound+    }++-----------------------------------------------+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].+-- This adds an error if the name cannot be found.+lookupExactOcc :: Name -> RnM Name+lookupExactOcc name+  = do { result <- lookupExactOcc_either name+       ; case result of+           Left err -> do { addErr err+                          ; return name }+           Right name' -> return name' }++-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].+-- This never adds an error, but it may return one.+lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)+-- See Note [Looking up Exact RdrNames]+lookupExactOcc_either name+  | Just thing <- wiredInNameTyThing_maybe name+  , Just tycon <- case thing of+                    ATyCon tc                 -> Just tc+                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)+                    _                         -> Nothing+  , isTupleTyCon tycon+  = do { checkTupSize (tyConArity tycon)+       ; return (Right name) }++  | isExternalName name+  = return (Right name)++  | otherwise+  = do { env <- getGlobalRdrEnv+       ; let -- See Note [Splicing Exact names]+             main_occ =  nameOccName name+             demoted_occs = case demoteOccName main_occ of+                              Just occ -> [occ]+                              Nothing  -> []+             gres = [ gre | occ <- main_occ : demoted_occs+                          , gre <- lookupGlobalRdrEnv env occ+                          , gre_name gre == name ]+       ; case gres of+           [gre] -> return (Right (gre_name gre))++           []    -> -- See Note [Splicing Exact names]+                    do { lcl_env <- getLocalRdrEnv+                       ; if name `inLocalRdrEnvScope` lcl_env+                         then return (Right name)+                         else+                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv+                            ; th_topnames <- readTcRef th_topnames_var+                            ; if name `elemNameSet` th_topnames+                              then return (Right name)+                              else return (Left exact_nm_err)+                            }+                       }+           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]+       }+  where+    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))+                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "+                              , text "perhaps via newName, but did not bind it"+                              , text "If that's it, then -ddump-splices might be useful" ])++sameNameErr :: [GlobalRdrElt] -> MsgDoc+sameNameErr [] = panic "addSameNameErr: empty list"+sameNameErr gres@(_ : _)+  = hang (text "Same exact name in multiple name-spaces:")+       2 (vcat (map pp_one sorted_names) $$ th_hint)+  where+    sorted_names = sortWith nameSrcLoc (map gre_name gres)+    pp_one name+      = hang (pprNameSpace (occNameSpace (getOccName name))+              <+> quotes (ppr name) <> comma)+           2 (text "declared at:" <+> ppr (nameSrcLoc name))++    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"+                   , text "perhaps via newName, in different name-spaces."+                   , text "If that's it, then -ddump-splices might be useful" ]+++-----------------------------------------------+lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name+-- This is called on the method name on the left-hand side of an+-- instance declaration binding. eg.  instance Functor T where+--                                       fmap = ...+--                                       ^^^^ called on this+-- Regardless of how many unqualified fmaps are in scope, we want+-- the one that comes from the Functor class.+--+-- Furthermore, note that we take no account of whether the+-- name is only in scope qualified.  I.e. even if method op is+-- in scope as M.op, we still allow plain 'op' on the LHS of+-- an instance decl+--+-- The "what" parameter says "method" or "associated type",+-- depending on what we are looking up+lookupInstDeclBndr cls what rdr+  = do { when (isQual rdr)+              (addErr (badQualBndrErr rdr))+                -- In an instance decl you aren't allowed+                -- to use a qualified name for the method+                -- (Although it'd make perfect sense.)+       ; mb_name <- lookupSubBndrOcc+                          False -- False => we don't give deprecated+                                -- warnings when a deprecated class+                                -- method is defined. We only warn+                                -- when it's used+                          cls doc rdr+       ; case mb_name of+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }+           Right nm -> return nm }+  where+    doc = what <+> text "of class" <+> quotes (ppr cls)++-----------------------------------------------+lookupFamInstName :: Maybe Name -> Located RdrName+                  -> RnM (Located Name)+-- Used for TyData and TySynonym family instances only,+-- See Note [Family instance binders]+lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Binds.rnMethodBind+  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr+lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*+  = lookupLocatedOccRn tc_rdr++-----------------------------------------------+lookupConstructorFields :: Name -> RnM [FieldLabel]+-- Look up the fields of a given constructor+--   *  For constructors from this module, use the record field env,+--      which is itself gathered from the (as yet un-typechecked)+--      data type decls+--+--    * For constructors from imported modules, use the *type* environment+--      since imported modules are already compiled, the info is conveniently+--      right there++lookupConstructorFields con_name+  = do  { this_mod <- getModule+        ; if nameIsLocalOrFrom this_mod con_name then+          do { field_env <- getRecFieldEnv+             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)+             ; return (lookupNameEnv field_env con_name `orElse` []) }+          else+          do { con <- tcLookupConLike con_name+             ; traceTc "lookupCF 2" (ppr con)+             ; return (conLikeFieldLabels con) } }+++-- In CPS style as `RnM r` is monadic+lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r+lookupExactOrOrig rdr_name res k+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code+  = res <$> lookupExactOcc n+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = res <$> lookupOrig rdr_mod rdr_occ+  | otherwise = k++++-----------------------------------------------+-- | Look up an occurrence of a field in record construction or pattern+-- matching (but not update).  When the -XDisambiguateRecordFields+-- flag is on, take account of the data constructor name to+-- disambiguate which field to use.+--+-- See Note [DisambiguateRecordFields].+lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual+                                -- Just con => use data con to disambiguate+                  -> RdrName+                  -> RnM Name+lookupRecFieldOcc mb_con rdr_name+  | Just con <- mb_con+  , isUnboundName con  -- Avoid error cascade+  = return (mkUnboundNameRdr rdr_name)+  | Just con <- mb_con+  = do { flds <- lookupConstructorFields con+       ; env <- getGlobalRdrEnv+       ; let lbl      = occNameFS (rdrNameOcc rdr_name)+             mb_field = do fl <- find ((== lbl) . flLabel) flds+                           -- We have the label, now check it is in+                           -- scope (with the correct qualifier if+                           -- there is one, hence calling pickGREs).+                           gre <- lookupGRE_FieldLabel env fl+                           guard (not (isQual rdr_name+                                         && null (pickGREs rdr_name [gre])))+                           return (fl, gre)+       ; case mb_field of+           Just (fl, gre) -> do { addUsedGRE True gre+                                ; return (flSelector fl) }+           Nothing        -> lookupGlobalOccRn rdr_name }+             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]+  | otherwise+  -- This use of Global is right as we are looking up a selector which+  -- can only be defined at the top level.+  = lookupGlobalOccRn rdr_name++{- Note [DisambiguateRecordFields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are looking up record fields in record construction or pattern+matching, we can take advantage of the data constructor name to+resolve fields that would otherwise be ambiguous (provided the+-XDisambiguateRecordFields flag is on).++For example, consider:++   data S = MkS { x :: Int }+   data T = MkT { x :: Int }++   e = MkS { x = 3 }++When we are renaming the occurrence of `x` in `e`, instead of looking+`x` up directly (and finding both fields), lookupRecFieldOcc will+search the fields of `MkS` to find the only possible `x` the user can+mean.++Of course, we still have to check the field is in scope, using+lookupGRE_FieldLabel.  The handling of qualified imports is slightly+subtle: the occurrence may be unqualified even if the field is+imported only qualified (but if the occurrence is qualified, the+qualifier must be correct). For example:++   module A where+     data S = MkS { x :: Int }+     data T = MkT { x :: Int }++   module B where+     import qualified A (S(..))+     import A (T(MkT))++     e1 = MkT   { x = 3 }   -- x not in scope, so fail+     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail+     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)++In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard+will fail because the field RdrName `B.x` is qualified and pickGREs+rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the+GRE for `A.x` and the guard will succeed because the field RdrName `x`+is unqualified.+++Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whenever we fail to find the field or it is not in scope, mb_field+will be False, and we fall back on looking it up normally using+lookupGlobalOccRn.  We don't report an error immediately because the+actual problem might be located elsewhere.  For example (#9975):++   data Test = Test { x :: Int }+   pattern Test wat = Test { x = wat }++Here there are multiple declarations of Test (as a data constructor+and as a pattern synonym), which will be reported as an error.  We+shouldn't also report an error about the occurrence of `x` in the+pattern synonym RHS.  However, if the pattern synonym gets added to+the environment first, we will try and fail to find `x` amongst the+(nonexistent) fields of the pattern synonym.++Alternatively, the scope check can fail due to Template Haskell.+Consider (#12130):++   module Foo where+     import M+     b = $(funny)++   module M(funny) where+     data T = MkT { x :: Int }+     funny :: Q Exp+     funny = [| MkT { x = 3 } |]++When we splice, `MkT` is not lexically in scope, so+lookupGRE_FieldLabel will fail.  But there is no need for+disambiguation anyway, because `x` is an original name, and+lookupGlobalOccRn will find it.+-}++++-- | Used in export lists to lookup the children.+lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName+                        -> RnM ChildLookupResult+lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name+  | isUnboundName parent+    -- Avoid an error cascade+  = return (FoundName NoParent (mkUnboundNameRdr rdr_name))++  | otherwise = do+  gre_env <- getGlobalRdrEnv++  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)+  -- Disambiguate the lookup based on the parent information.+  -- The remaining GREs are things that we *could* export here, note that+  -- this includes things which have `NoParent`. Those are sorted in+  -- `checkPatSynParent`.+  traceRn "parent" (ppr parent)+  traceRn "lookupExportChild original_gres:" (ppr original_gres)+  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)+  case picked_gres original_gres of+    NoOccurrence ->+      noMatchingParentErr original_gres+    UniqueOccurrence g ->+      if must_have_parent then noMatchingParentErr original_gres+                          else checkFld g+    DisambiguatedOccurrence g ->+      checkFld g+    AmbiguousOccurrence gres ->+      mkNameClashErr gres+    where+        -- Convert into FieldLabel if necessary+        checkFld :: GlobalRdrElt -> RnM ChildLookupResult+        checkFld g@GRE{gre_name, gre_par} = do+          addUsedGRE warn_if_deprec g+          return $ case gre_par of+            FldParent _ mfs ->+              FoundFL  (fldParentToFieldLabel gre_name mfs)+            _ -> FoundName gre_par gre_name++        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel+        fldParentToFieldLabel name mfs =+          case mfs of+            Nothing ->+              let fs = occNameFS (nameOccName name)+              in FieldLabel fs False name+            Just fs -> FieldLabel fs True name++        -- Called when we find no matching GREs after disambiguation but+        -- there are three situations where this happens.+        -- 1. There were none to begin with.+        -- 2. None of the matching ones were the parent but+        --  a. They were from an overloaded record field so we can report+        --     a better error+        --  b. The original lookup was actually ambiguous.+        --     For example, the case where overloading is off and two+        --     record fields are in scope from different record+        --     constructors, neither of which is the parent.+        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        noMatchingParentErr original_gres = do+          overload_ok <- xoptM LangExt.DuplicateRecordFields+          case original_gres of+            [] ->  return NameNotFound+            [g] -> return $ IncorrectParent parent+                              (gre_name g) (ppr $ gre_name g)+                              [p | Just p <- [getParent g]]+            gss@(g:_:_) ->+              if all isRecFldGRE gss && overload_ok+                then return $+                      IncorrectParent parent+                        (gre_name g)+                        (ppr $ expectJust "noMatchingParentErr" (greLabel g))+                        [p | x <- gss, Just p <- [getParent x]]+                else mkNameClashErr gss++        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        mkNameClashErr gres = do+          addNameClashErrRn rdr_name gres+          return (FoundName (gre_par (head gres)) (gre_name (head gres)))++        getParent :: GlobalRdrElt -> Maybe Name+        getParent (GRE { gre_par = p } ) =+          case p of+            ParentIs cur_parent -> Just cur_parent+            FldParent { par_is = cur_parent } -> Just cur_parent+            NoParent -> Nothing++        picked_gres :: [GlobalRdrElt] -> DisambigInfo+        -- For Unqual, find GREs that are in scope qualified or unqualified+        -- For Qual,   find GREs that are in scope with that qualification+        picked_gres gres+          | isUnqual rdr_name+          = mconcat (map right_parent gres)+          | otherwise+          = mconcat (map right_parent (pickGREs rdr_name gres))++        right_parent :: GlobalRdrElt -> DisambigInfo+        right_parent p+          = case getParent p of+               Just cur_parent+                  | parent == cur_parent -> DisambiguatedOccurrence p+                  | otherwise            -> NoOccurrence+               Nothing                   -> UniqueOccurrence p+++-- This domain specific datatype is used to record why we decided it was+-- possible that a GRE could be exported with a parent.+data DisambigInfo+       = NoOccurrence+          -- The GRE could never be exported. It has the wrong parent.+       | UniqueOccurrence GlobalRdrElt+          -- The GRE has no parent. It could be a pattern synonym.+       | DisambiguatedOccurrence GlobalRdrElt+          -- The parent of the GRE is the correct parent+       | AmbiguousOccurrence [GlobalRdrElt]+          -- For example, two normal identifiers with the same name are in+          -- scope. They will both be resolved to "UniqueOccurrence" and the+          -- monoid will combine them to this failing case.++instance Outputable DisambigInfo where+  ppr NoOccurrence = text "NoOccurence"+  ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre+  ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre+  ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres++instance Semi.Semigroup DisambigInfo where+  -- This is the key line: We prefer disambiguated occurrences to other+  -- names.+  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'+  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'++  NoOccurrence <> m = m+  m <> NoOccurrence = m+  UniqueOccurrence g <> UniqueOccurrence g'+    = AmbiguousOccurrence [g, g']+  UniqueOccurrence g <> AmbiguousOccurrence gs+    = AmbiguousOccurrence (g:gs)+  AmbiguousOccurrence gs <> UniqueOccurrence g'+    = AmbiguousOccurrence (g':gs)+  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'+    = AmbiguousOccurrence (gs ++ gs')++instance Monoid DisambigInfo where+  mempty = NoOccurrence+  mappend = (Semi.<>)++-- Lookup SubBndrOcc can never be ambiguous+--+-- Records the result of looking up a child.+data ChildLookupResult+      = NameNotFound                --  We couldn't find a suitable name+      | IncorrectParent Name        -- Parent+                        Name        -- Name of thing we were looking for+                        SDoc        -- How to print the name+                        [Name]      -- List of possible parents+      | FoundName Parent Name       --  We resolved to a normal name+      | FoundFL FieldLabel          --  We resolved to a FL++-- | Specialised version of msum for RnM ChildLookupResult+combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult+combineChildLookupResult [] = return NameNotFound+combineChildLookupResult (x:xs) = do+  res <- x+  case res of+    NameNotFound -> combineChildLookupResult xs+    _ -> return res++instance Outputable ChildLookupResult where+  ppr NameNotFound = text "NameNotFound"+  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n+  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls+  ppr (IncorrectParent p n td ns) = text "IncorrectParent"+                                  <+> hsep [ppr p, ppr n, td, ppr ns]++lookupSubBndrOcc :: Bool+                 -> Name     -- Parent+                 -> SDoc+                 -> RdrName+                 -> RnM (Either MsgDoc Name)+-- Find all the things the rdr-name maps to+-- and pick the one with the right parent namep+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do+  res <-+    lookupExactOrOrig rdr_name (FoundName NoParent) $+      -- This happens for built-in classes, see mod052 for example+      lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name+  case res of+    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))+    FoundName _p n -> return (Right n)+    FoundFL fl  ->  return (Right (flSelector fl))+    IncorrectParent {}+         -- See [Mismatched class methods and associated type families]+         -- in TcInstDecls.+      -> return $ Left (unknownSubordinateErr doc rdr_name)++{-+Note [Family instance binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data family F a+  data instance F T = X1 | X2++The 'data instance' decl has an *occurrence* of F (and T), and *binds*+X1 and X2.  (This is unlike a normal data type declaration which would+bind F too.)  So we want an AvailTC F [X1,X2].++Now consider a similar pair:+  class C a where+    data G a+  instance C S where+    data G S = Y1 | Y2++The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.++But there is a small complication: in an instance decl, we don't use+qualified names on the LHS; instead we use the class to disambiguate.+Thus:+  module M where+    import Blib( G )+    class C a where+      data G a+    instance C S where+      data G S = Y1 | Y2+Even though there are two G's in scope (M.G and Blib.G), the occurrence+of 'G' in the 'instance C S' decl is unambiguous, because C has only+one associated type called G. This is exactly what happens for methods,+and it is only consistent to do the same thing for types. That's the+role of the function lookupTcdName; the (Maybe Name) give the class of+the encloseing instance decl, if any.++Note [Looking up Exact RdrNames]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exact RdrNames are generated by Template Haskell.  See Note [Binders+in Template Haskell] in Convert.++For data types and classes have Exact system Names in the binding+positions for constructors, TyCons etc.  For example+    [d| data T = MkT Int |]+when we splice in and Convert to HsSyn RdrName, we'll get+    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...+These System names are generated by Convert.thRdrName++But, constructors and the like need External Names, not System Names!+So we do the following++ * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a+   non-External Name, and make an External name for it. This is+   the name that goes in the GlobalRdrEnv++ * When looking up an occurrence of an Exact name, done in+   GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the+   GlobalRdrEnv, and use the one from the envt -- it will be an+   External Name in the case of the data type/constructor above.++ * Exact names are also use for purely local binders generated+   by TH, such as    \x_33. x_33+   Both binder and occurrence are Exact RdrNames.  The occurrence+   gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and+   misses, because lookupLocalRdrEnv always returns Nothing for+   an Exact Name.  Now we fall through to lookupExactOcc, which+   will find the Name is not in the GlobalRdrEnv, so we just use+   the Exact supplied Name.++Note [Splicing Exact names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the splice $(do { x <- newName "x"; return (VarE x) })+This will generate a (HsExpr RdrName) term that mentions the+Exact RdrName "x_56" (or whatever), but does not bind it.  So+when looking such Exact names we want to check that it's in scope,+otherwise the type checker will get confused.  To do this we need to+keep track of all the Names in scope, and the LocalRdrEnv does just that;+we consult it with RdrName.inLocalRdrEnvScope.++There is another wrinkle.  With TH and -XDataKinds, consider+   $( [d| data Nat = Zero+          data T = MkT (Proxy 'Zero)  |] )+After splicing, but before renaming we get this:+   data Nat_77{tc} = Zero_78{d}+   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )+The occurrence of 'Zero in the data type for T has the right unique,+but it has a TcClsName name-space in its OccName.  (This is set by+the ctxt_ns argument of Convert.thRdrName.)  When we check that is+in scope in the GlobalRdrEnv, we need to look up the DataName namespace+too.  (An alternative would be to make the GlobalRdrEnv also have+a Name -> GRE mapping.)++Note [Template Haskell ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GlobalRdrEnv invariant says that if+  occ -> [gre1, ..., gren]+then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).+This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).++So how can we get multiple gres in lookupExactOcc_maybe?  Because in+TH we might use the same TH NameU in two different name spaces.+eg (#7241):+   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])+Here we generate a type constructor and data constructor with the same+unique, but different name spaces.++It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would+mean looking up the OccName in every name-space, just in case, and that+seems a bit brutal.  So it's just done here on lookup.  But we might+need to revisit that choice.++Note [Usage for sub-bndrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+If you have this+   import qualified M( C( f ) )+   instance M.C T where+     f x = x+then is the qualified import M.f used?  Obviously yes.+But the RdrName used in the instance decl is unqualified.  In effect,+we fill in the qualification by looking for f's whose class is M.C+But when adding to the UsedRdrNames we must make that qualification+explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".++So we make up a suitable (fake) RdrName.  But be careful+   import qualified M+   import M( C(f) )+   instance C T where+     f x = x+Here we want to record a use of 'f', not of 'M.f', otherwise+we'll miss the fact that the qualified import is redundant.++--------------------------------------------------+--              Occurrences+--------------------------------------------------+-}+++lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)+lookupLocatedOccRn = wrapLocM lookupOccRn++lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- Just look in the local environment+lookupLocalOccRn_maybe rdr_name+  = do { local_env <- getLocalRdrEnv+       ; return (lookupLocalRdrEnv local_env rdr_name) }++lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))+-- Just look in the local environment+lookupLocalOccThLvl_maybe name+  = do { lcl_env <- getLclEnv+       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }++-- lookupOccRn looks up an occurrence of a RdrName+lookupOccRn :: RdrName -> RnM Name+lookupOccRn rdr_name+  = do { mb_name <- lookupOccRn_maybe rdr_name+       ; case mb_name of+           Just name -> return name+           Nothing   -> reportUnboundName rdr_name }++-- Only used in one place, to rename pattern synonym binders.+-- See Note [Renaming pattern synonym variables] in GHC.Rename.Binds+lookupLocalOccRn :: RdrName -> RnM Name+lookupLocalOccRn rdr_name+  = do { mb_name <- lookupLocalOccRn_maybe rdr_name+       ; case mb_name of+           Just name -> return name+           Nothing   -> unboundName WL_LocalOnly rdr_name }++-- lookupPromotedOccRn looks up an optionally promoted RdrName.+lookupTypeOccRn :: RdrName -> RnM Name+-- see Note [Demotion]+lookupTypeOccRn rdr_name+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]+  = badVarInType rdr_name+  | otherwise+  = do { mb_name <- lookupOccRn_maybe rdr_name+       ; case mb_name of+             Just name -> return name+             Nothing   -> lookup_demoted rdr_name }++lookup_demoted :: RdrName -> RnM Name+lookup_demoted rdr_name+  | Just demoted_rdr <- demoteRdrName rdr_name+    -- Maybe it's the name of a *data* constructor+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; star_is_type <- xoptM LangExt.StarIsType+       ; let star_info = starInfo star_is_type rdr_name+       ; if data_kinds+            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr+                    ; case mb_demoted_name of+                        Nothing -> unboundNameX WL_Any rdr_name star_info+                        Just demoted_name ->+                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $+                               addWarn+                                 (Reason Opt_WarnUntickedPromotedConstructors)+                                 (untickedPromConstrWarn demoted_name)+                             ; return demoted_name } }+            else do { -- We need to check if a data constructor of this name is+                      -- in scope to give good error messages. However, we do+                      -- not want to give an additional error if the data+                      -- constructor happens to be out of scope! See #13947.+                      mb_demoted_name <- discardErrs $+                                         lookupOccRn_maybe demoted_rdr+                    ; let suggestion | isJust mb_demoted_name = suggest_dk+                                     | otherwise = star_info+                    ; unboundNameX WL_Any rdr_name suggestion } }++  | otherwise+  = reportUnboundName rdr_name++  where+    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"+    untickedPromConstrWarn name =+      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot+      $$+      hsep [ text "Use"+           , quotes (char '\'' <> ppr name)+           , text "instead of"+           , quotes (ppr name) <> dot ]++badVarInType :: RdrName -> RnM Name+badVarInType rdr_name+  = do { addErr (text "Illegal promoted term variable in a type:"+                 <+> ppr rdr_name)+       ; return (mkUnboundNameRdr rdr_name) }++{- Note [Promoted variables in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#12686):+   x = True+   data Bad = Bad 'x++The parser treats the quote in 'x as saying "use the term+namespace", so we'll get (Bad x{v}), with 'x' in the+VarName namespace.  If we don't test for this, the renamer+will happily rename it to the x bound at top level, and then+the typecheck falls over because it doesn't have 'x' in scope+when kind-checking.++Note [Demotion]+~~~~~~~~~~~~~~~+When the user writes:+  data Nat = Zero | Succ Nat+  foo :: f Zero -> Int++'Zero' in the type signature of 'foo' is parsed as:+  HsTyVar ("Zero", TcClsName)++When the renamer hits this occurrence of 'Zero' it's going to realise+that it's not in scope. But because it is renaming a type, it knows+that 'Zero' might be a promoted data constructor, so it will demote+its namespace to DataName and do a second lookup.++The final result (after the renamer) will be:+  HsTyVar ("Zero", DataName)+-}++lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName+                   -> RnM (Maybe r)+lookupOccRnX_maybe globalLookup wrapper rdr_name+  = runMaybeT . msum . map MaybeT $+      [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name+      , globalLookup rdr_name ]++lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)+lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id++lookupOccRn_overloaded :: Bool -> RdrName+                       -> RnM (Maybe (Either Name [Name]))+lookupOccRn_overloaded overload_ok+  = lookupOccRnX_maybe global_lookup Left+      where+        global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))+        global_lookup n =+          runMaybeT . msum . map MaybeT $+            [ lookupGlobalOccRn_overloaded overload_ok n+            , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]++++lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- Looks up a RdrName occurrence in the top-level+--   environment, including using lookupQualifiedNameGHCi+--   for the GHCi case+-- No filter function; does not report an error on failure+-- Uses addUsedRdrName to record use and deprecations+lookupGlobalOccRn_maybe rdr_name =+  lookupExactOrOrig rdr_name Just $+    runMaybeT . msum . map MaybeT $+      [ fmap gre_name <$> lookupGreRn_maybe rdr_name+      , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]+                      -- This test is not expensive,+                      -- and only happens for failed lookups++lookupGlobalOccRn :: RdrName -> RnM Name+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global+-- environment.  Adds an error message if the RdrName is not in scope.+-- You usually want to use "lookupOccRn" which also looks in the local+-- environment.+lookupGlobalOccRn rdr_name+  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name+       ; case mb_name of+           Just n  -> return n+           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)+                         ; unboundName WL_Global rdr_name } }++lookupInfoOccRn :: RdrName -> RnM [Name]+-- lookupInfoOccRn is intended for use in GHCi's ":info" command+-- It finds all the GREs that RdrName could mean, not complaining+-- about ambiguity, but rather returning them all+-- C.f. #9881+lookupInfoOccRn rdr_name =+  lookupExactOrOrig rdr_name (:[]) $+    do { rdr_env <- getGlobalRdrEnv+       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)+       ; qual_ns <- lookupQualifiedNameGHCi rdr_name+       ; return (ns ++ (qual_ns `minusList` ns)) }++-- | Like 'lookupOccRn_maybe', but with a more informative result if+-- the 'RdrName' happens to be a record selector:+--+--   * Nothing         -> name not in scope (no error reported)+--   * Just (Left x)   -> name uniquely refers to x,+--                        or there is a name clash (reported)+--   * Just (Right xs) -> name refers to one or more record selectors;+--                        if overload_ok was False, this list will be+--                        a singleton.++lookupGlobalOccRn_overloaded :: Bool -> RdrName+                             -> RnM (Maybe (Either Name [Name]))+lookupGlobalOccRn_overloaded overload_ok rdr_name =+  lookupExactOrOrig rdr_name (Just . Left) $+     do  { res <- lookupGreRn_helper rdr_name+         ; case res of+                GreNotFound  -> return Nothing+                OneNameMatch gre -> do+                  let wrapper = if isRecFldGRE gre then Right . (:[]) else Left+                  return $ Just (wrapper (gre_name gre))+                MultipleNames gres  | all isRecFldGRE gres && overload_ok ->+                  -- Don't record usage for ambiguous selectors+                  -- until we know which is meant+                  return $ Just (Right (map gre_name gres))+                MultipleNames gres  -> do+                  addNameClashErrRn rdr_name gres+                  return (Just (Left (gre_name (head gres)))) }+++--------------------------------------------------+--      Lookup in the Global RdrEnv of the module+--------------------------------------------------++data GreLookupResult = GreNotFound+                     | OneNameMatch GlobalRdrElt+                     | MultipleNames [GlobalRdrElt]++lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)+-- Look up the RdrName in the GlobalRdrEnv+--   Exactly one binding: records it as "used", return (Just gre)+--   No bindings:         return Nothing+--   Many bindings:       report "ambiguous", return an arbitrary (Just gre)+-- Uses addUsedRdrName to record use and deprecations+lookupGreRn_maybe rdr_name+  = do+      res <- lookupGreRn_helper rdr_name+      case res of+        OneNameMatch gre ->  return $ Just gre+        MultipleNames gres -> do+          traceRn "lookupGreRn_maybe:NameClash" (ppr gres)+          addNameClashErrRn rdr_name gres+          return $ Just (head gres)+        GreNotFound -> return Nothing++{-++Note [ Unbound vs Ambiguous Names ]++lookupGreRn_maybe deals with failures in two different ways. If a name+is unbound then we return a `Nothing` but if the name is ambiguous+then we raise an error and return a dummy name.++The reason for this is that when we call `lookupGreRn_maybe` we are+speculatively looking for whatever we are looking up. If we don't find it,+then we might have been looking for the wrong thing and can keep trying.+On the other hand, if we find a clash then there is no way to recover as+we found the thing we were looking for but can no longer resolve which+the correct one is.++One example of this is in `lookupTypeOccRn` which first looks in the type+constructor namespace before looking in the data constructor namespace to+deal with `DataKinds`.++There is however, as always, one exception to this scheme. If we find+an ambiguous occurrence of a record selector and DuplicateRecordFields+is enabled then we defer the selection until the typechecker.++-}+++++-- Internal Function+lookupGreRn_helper :: RdrName -> RnM GreLookupResult+lookupGreRn_helper rdr_name+  = do  { env <- getGlobalRdrEnv+        ; case lookupGRE_RdrName rdr_name env of+            []    -> return GreNotFound+            [gre] -> do { addUsedGRE True gre+                        ; return (OneNameMatch gre) }+            gres  -> return (MultipleNames gres) }++lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)+-- Used in export lists+-- If not found or ambiguous, add error message, and fake with UnboundName+-- Uses addUsedRdrName to record use and deprecations+lookupGreAvailRn rdr_name+  = do+      mb_gre <- lookupGreRn_helper rdr_name+      case mb_gre of+        GreNotFound ->+          do+            traceRn "lookupGreAvailRn" (ppr rdr_name)+            name <- unboundName WL_Global rdr_name+            return (name, avail name)+        MultipleNames gres ->+          do+            addNameClashErrRn rdr_name gres+            let unbound_name = mkUnboundNameRdr rdr_name+            return (unbound_name, avail unbound_name)+                        -- Returning an unbound name here prevents an error+                        -- cascade+        OneNameMatch gre ->+          return (gre_name gre, availFromGRE gre)+++{-+*********************************************************+*                                                      *+                Deprecations+*                                                      *+*********************************************************++Note [Handling of deprecations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* We report deprecations at each *occurrence* of the deprecated thing+  (see #5867)++* We do not report deprecations for locally-defined names. For a+  start, we may be exporting a deprecated thing. Also we may use a+  deprecated thing in the defn of another deprecated things.  We may+  even use a deprecated thing in the defn of a non-deprecated thing,+  when changing a module's interface.++* addUsedGREs: we do not report deprecations for sub-binders:+     - the ".." completion for records+     - the ".." in an export item 'T(..)'+     - the things exported by a module export 'module M'+-}++addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()+-- Remember use of in-scope data constructors (#7969)+addUsedDataCons rdr_env tycon+  = addUsedGREs [ gre+                | dc <- tyConDataCons tycon+                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]++addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()+-- Called for both local and imported things+-- Add usage *and* warn if deprecated+addUsedGRE warn_if_deprec gre+  = do { when warn_if_deprec (warnIfDeprecated gre)+       ; unless (isLocalGRE gre) $+         do { env <- getGblEnv+            ; traceRn "addUsedGRE" (ppr gre)+            ; updMutVar (tcg_used_gres env) (gre :) } }++addUsedGREs :: [GlobalRdrElt] -> RnM ()+-- Record uses of any *imported* GREs+-- Used for recording used sub-bndrs+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]+addUsedGREs gres+  | null imp_gres = return ()+  | otherwise     = do { env <- getGblEnv+                       ; traceRn "addUsedGREs" (ppr imp_gres)+                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }+  where+    imp_gres = filterOut isLocalGRE gres++warnIfDeprecated :: GlobalRdrElt -> RnM ()+warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })+  | (imp_spec : _) <- iss+  = do { dflags <- getDynFlags+       ; this_mod <- getModule+       ; when (wopt Opt_WarnWarningsDeprecations dflags &&+               not (nameIsLocalOrFrom this_mod name)) $+                   -- See Note [Handling of deprecations]+         do { iface <- loadInterfaceForName doc name+            ; case lookupImpDeprec iface gre of+                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)+                                   (mk_msg imp_spec txt)+                Nothing  -> return () } }+  | otherwise+  = return ()+  where+    occ = greOccName gre+    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")++    mk_msg imp_spec txt+      = sep [ sep [ text "In the use of"+                    <+> pprNonVarNameSpace (occNameSpace occ)+                    <+> quotes (ppr occ)+                  , parens imp_msg <> colon ]+            , pprWarningTxtForMsg txt ]+      where+        imp_mod  = importSpecModule imp_spec+        imp_msg  = text "imported from" <+> ppr imp_mod <> extra+        extra | imp_mod == moduleName name_mod = Outputable.empty+              | otherwise = text ", but defined in" <+> ppr name_mod++lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt+lookupImpDeprec iface gre+  = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,+    case gre_par gre of                      -- or its parent, is warn'd+       ParentIs  p              -> mi_warn_fn (mi_final_exts iface) (nameOccName p)+       FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p)+       NoParent                 -> Nothing++{-+Note [Used names with interface not loaded]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's (just) possible to find a used+Name whose interface hasn't been loaded:++a) It might be a WiredInName; in that case we may not load+   its interface (although we could).++b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger+   These are seen as "used" by the renamer (if -XRebindableSyntax)+   is on), but the typechecker may discard their uses+   if in fact the in-scope fromRational is GHC.Read.fromRational,+   (see tcPat.tcOverloadedLit), and the typechecker sees that the type+   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).+   In that obscure case it won't force the interface in.++In both cases we simply don't permit deprecations;+this is, after all, wired-in stuff.+++*********************************************************+*                                                      *+                GHCi support+*                                                      *+*********************************************************++A qualified name on the command line can refer to any module at+all: we try to load the interface if we don't already have it, just+as if there was an "import qualified M" declaration for every+module.++For example, writing `Data.List.sort` will load the interface file for+`Data.List` as if the user had written `import qualified Data.List`.++If we fail we just return Nothing, rather than bleating+about "attempting to use module ‘D’ (./D.hs) which is not loaded"+which is what loadSrcInterface does.++It is enabled by default and disabled by the flag+`-fno-implicit-import-qualified`.++Note [Safe Haskell and GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We DON'T do this Safe Haskell as we need to check imports. We can+and should instead check the qualified import but at the moment+this requires some refactoring so leave as a TODO+-}++++lookupQualifiedNameGHCi :: RdrName -> RnM [Name]+lookupQualifiedNameGHCi rdr_name+  = -- We want to behave as we would for a source file import here,+    -- and respect hiddenness of modules/packages, hence loadSrcInterface.+    do { dflags  <- getDynFlags+       ; is_ghci <- getIsGHCi+       ; go_for_it dflags is_ghci }++  where+    go_for_it dflags is_ghci+      | Just (mod,occ) <- isQual_maybe rdr_name+      , is_ghci+      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour+      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]+      = do { res <- loadSrcInterface_maybe doc mod False Nothing+           ; case res of+                Succeeded iface+                  -> return [ name+                            | avail <- mi_exports iface+                            , name  <- availNames avail+                            , nameOccName name == occ ]++                _ -> -- Either we couldn't load the interface, or+                     -- we could but we didn't find the name in it+                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)+                        ; return [] } }++      | otherwise+      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)+           ; return [] }++    doc = text "Need to find" <+> ppr rdr_name++{-+Note [Looking up signature names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+lookupSigOccRn is used for type signatures and pragmas+Is this valid?+  module A+        import M( f )+        f :: Int -> Int+        f x = x+It's clear that the 'f' in the signature must refer to A.f+The Haskell98 report does not stipulate this, but it will!+So we must treat the 'f' in the signature in the same way+as the binding occurrence of 'f', using lookupBndrRn++However, consider this case:+        import M( f )+        f :: Int -> Int+        g x = x+We don't want to say 'f' is out of scope; instead, we want to+return the imported 'f', so that later on the renamer will+correctly report "misplaced type sig".++Note [Signatures for top level things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+data HsSigCtxt = ... | TopSigCtxt NameSet | ....++* The NameSet says what is bound in this group of bindings.+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:+       f x = x+       $( ...some TH splice... )+       f :: Int -> Int+  When we encounter the signature for 'f', the binding for 'f'+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the+  signature is mis-placed++* For type signatures the NameSet should be the names bound by the+  value bindings; for fixity declarations, the NameSet should also+  include class sigs and record selectors++      infix 3 `f`          -- Yes, ok+      f :: C a => a -> a   -- No, not ok+      class C a where+        f :: a -> a+-}++data HsSigCtxt+  = TopSigCtxt NameSet       -- At top level, binding these names+                             -- See Note [Signatures for top level things]+  | LocalBindCtxt NameSet    -- In a local binding, binding these names+  | ClsDeclCtxt   Name       -- Class decl for this class+  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method+                             -- bindings are for these methods+  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names+  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types+                             -- in the group++instance Outputable HsSigCtxt where+    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns+    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns+    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n+    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns+    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns+    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns++lookupSigOccRn :: HsSigCtxt+               -> Sig GhcPs+               -> Located RdrName -> RnM (Located Name)+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)++-- | Lookup a name in relation to the names in a 'HsSigCtxt'+lookupSigCtxtOccRn :: HsSigCtxt+                   -> SDoc         -- ^ description of thing we're looking up,+                                   -- like "type family"+                   -> Located RdrName -> RnM (Located Name)+lookupSigCtxtOccRn ctxt what+  = wrapLocM $ \ rdr_name ->+    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name+       ; case mb_name of+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Right name -> return name }++lookupBindGroupOcc :: HsSigCtxt+                   -> SDoc+                   -> RdrName -> RnM (Either MsgDoc Name)+-- Looks up the RdrName, expecting it to resolve to one of the+-- bound names passed in.  If not, return an appropriate error message+--+-- See Note [Looking up signature names]+lookupBindGroupOcc ctxt what rdr_name+  | Just n <- isExact_maybe rdr_name+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;+                              -- see Note [dataTcOccs and Exact Names]+      -- Maybe we should check the side conditions+      -- but it's a pain, and Exact things only show+      -- up when you know what you are doing++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n' <- lookupOrig rdr_mod rdr_occ+       ; return (Right n') }++  | otherwise+  = case ctxt of+      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)+      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)+      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)+      LocalBindCtxt ns -> lookup_group ns+      ClsDeclCtxt  cls -> lookup_cls_op cls+      InstDeclCtxt ns  -> if uniqSetAny isUnboundName ns -- #16610+                          then return (Right $ mkUnboundNameRdr rdr_name)+                          else lookup_top (`elemNameSet` ns)+  where+    lookup_cls_op cls+      = lookupSubBndrOcc True cls doc rdr_name+      where+        doc = text "method of class" <+> quotes (ppr cls)++    lookup_top keep_me+      = do { env <- getGlobalRdrEnv+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)+                 names_in_scope = -- If rdr_name lacks a binding, only+                                  -- recommend alternatives from related+                                  -- namespaces. See #17593.+                                  filter (\n -> nameSpacesRelated+                                                  (rdrNameSpace rdr_name)+                                                  (nameNameSpace n))+                                $ map gre_name+                                $ filter isLocalGRE+                                $ globalRdrEnvElts env+                 candidates_msg = candidates names_in_scope+           ; case filter (keep_me . gre_name) all_gres of+               [] | null all_gres -> bale_out_with candidates_msg+                  | otherwise     -> bale_out_with local_msg+               (gre:_)            -> return (Right (gre_name gre)) }++    lookup_group bound_names  -- Look in the local envt (not top level)+      = do { mname <- lookupLocalOccRn_maybe rdr_name+           ; env <- getLocalRdrEnv+           ; let candidates_msg = candidates $ localRdrEnvElts env+           ; case mname of+               Just n+                 | n `elemNameSet` bound_names -> return (Right n)+                 | otherwise                   -> bale_out_with local_msg+               Nothing                         -> bale_out_with candidates_msg }++    bale_out_with msg+        = return (Left (sep [ text "The" <+> what+                                <+> text "for" <+> quotes (ppr rdr_name)+                           , nest 2 $ text "lacks an accompanying binding"]+                       $$ nest 2 msg))++    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")+                           <+> quotes (ppr rdr_name) <+> text "is declared"++    -- Identify all similar names and produce a message listing them+    candidates :: [Name] -> MsgDoc+    candidates names_in_scope+      = case similar_names of+          []  -> Outputable.empty+          [n] -> text "Perhaps you meant" <+> pp_item n+          _   -> sep [ text "Perhaps you meant one of these:"+                     , nest 2 (pprWithCommas pp_item similar_names) ]+      where+        similar_names+          = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)+                        $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))+                              names_in_scope++        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x)+++---------------+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]+-- GHC extension: look up both the tycon and data con or variable.+-- Used for top-level fixity signatures and deprecations.+-- Complain if neither is in scope.+-- See Note [Fixity signature lookup]+lookupLocalTcNames ctxt what rdr_name+  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)+       ; let (errs, names) = partitionEithers mb_gres+       ; when (null names) $ addErr (head errs) -- Bleat about one only+       ; return names }+  where+    lookup rdr = do { this_mod <- getModule+                    ; nameEither <- lookupBindGroupOcc ctxt what rdr+                    ; return (guard_builtin_syntax this_mod rdr nameEither) }++    -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233+    guard_builtin_syntax this_mod rdr (Right name)+      | Just _ <- isBuiltInOcc_maybe (occName rdr)+      , this_mod /= nameModule name+      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])+      | otherwise+      = Right (rdr, name)+    guard_builtin_syntax _ _ (Left err) = Left err++dataTcOccs :: RdrName -> [RdrName]+-- Return both the given name and the same name promoted to the TcClsName+-- namespace.  This is useful when we aren't sure which we are looking at.+-- See also Note [dataTcOccs and Exact Names]+dataTcOccs rdr_name+  | isDataOcc occ || isVarOcc occ+  = [rdr_name, rdr_name_tc]+  | otherwise+  = [rdr_name]+  where+    occ = rdrNameOcc rdr_name+    rdr_name_tc =+      case rdr_name of+        -- The (~) type operator is always in scope, so we need a special case+        -- for it here, or else  :info (~)  fails in GHCi.+        -- See Note [eqTyCon (~) is built-in syntax]+        Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR+        _ -> setRdrNameSpace rdr_name tcName++{-+Note [dataTcOccs and Exact Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exact RdrNames can occur in code generated by Template Haskell, and generally+those references are, well, exact. However, the TH `Name` type isn't expressive+enough to always track the correct namespace information, so we sometimes get+the right Unique but wrong namespace. Thus, we still have to do the double-lookup+for Exact RdrNames.++There is also an awkward situation for built-in syntax. Example in GHCi+   :info []+This parses as the Exact RdrName for nilDataCon, but we also want+the list type constructor.++Note that setRdrNameSpace on an Exact name requires the Name to be External,+which it always is for built in syntax.+-}++++{-+************************************************************************+*                                                                      *+                        Rebindable names+        Dealing with rebindable syntax is driven by the+        Opt_RebindableSyntax dynamic flag.++        In "deriving" code we don't want to use rebindable syntax+        so we switch off the flag locally++*                                                                      *+************************************************************************++Haskell 98 says that when you say "3" you get the "fromInteger" from the+Standard Prelude, regardless of what is in scope.   However, to experiment+with having a language that is less coupled to the standard prelude, we're+trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"+happens to be in scope.  Then you can+        import Prelude ()+        import MyPrelude as Prelude+to get the desired effect.++At the moment this just happens for+  * fromInteger, fromRational on literals (in expressions and patterns)+  * negate (in expressions)+  * minus  (arising from n+k patterns)+  * "do" notation++We store the relevant Name in the HsSyn tree, in+  * HsIntegral/HsFractional/HsIsString+  * NegApp+  * NPlusKPat+  * HsDo+respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,+fromRationalName etc), but the renamer changes this to the appropriate user+name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.++We treat the original (standard) names as free-vars too, because the type checker+checks the type of the user thing against the type of the standard thing.+-}++lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)+-- Different to lookupSyntaxName because in the non-rebindable+-- case we desugar directly rather than calling an existing function+-- Hence the (Maybe (SyntaxExpr GhcRn)) return type+lookupIfThenElse+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on+         then return (Nothing, emptyFVs)+         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))+                 ; return ( Just (mkRnSyntaxExpr ite)+                          , unitFV ite ) } }++lookupSyntaxName' :: Name          -- ^ The standard name+                  -> RnM Name      -- ^ Possibly a non-standard name+lookupSyntaxName' std_name+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+           return std_name+         else+            -- Get the similarly named thing from the local environment+           lookupOccRn (mkRdrUnqual (nameOccName std_name)) }++lookupSyntaxName :: Name                             -- The standard name+                 -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard+                                                     -- name+lookupSyntaxName std_name+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+           return (mkRnSyntaxExpr std_name, emptyFVs)+         else+            -- Get the similarly named thing from the local environment+           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }++lookupSyntaxNames :: [Name]                         -- Standard names+     -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs+lookupSyntaxNames std_names+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+             return (map (HsVar noExtField . noLoc) std_names, emptyFVs)+        else+          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names+             ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }++-- Error messages+++opDeclErr :: RdrName -> SDoc+opDeclErr n+  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))+       2 (text "Use TypeOperators to declare operators in type and declarations")++badOrigBinding :: RdrName -> SDoc+badOrigBinding name+  | Just _ <- isBuiltInOcc_maybe occ+  = text "Illegal binding of built-in syntax:" <+> ppr occ+    -- Use an OccName here because we don't want to print Prelude.(,)+  | otherwise+  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"+    <+> ppr name+    -- This can happen when one tries to use a Template Haskell splice to+    -- define a top-level identifier with an already existing name, e.g.,+    --+    --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])+    --+    -- (See #13968.)+  where+    occ = rdrNameOcc $ filterCTuple name
+ compiler/GHC/Rename/Expr.hs view
@@ -0,0 +1,2211 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Renaming of expressions++Basically dependency analysis.++Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In+general, all of these functions return a renamed thing, and a set of+free variables.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++module GHC.Rename.Expr (+        rnLExpr, rnExpr, rnStmts+   ) where++#include "HsVersions.h"++import GhcPrelude++import GHC.Rename.Binds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS+                        , rnMatchGroup, rnGRHS, makeMiniFixityEnv)+import GHC.Hs+import TcEnv            ( isBrackStage )+import TcRnMonad+import Module           ( getModule )+import GHC.Rename.Env+import GHC.Rename.Fixity+import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames+                        , bindLocalNames+                        , mapMaybeFvRn, mapFvRn+                        , warnUnusedLocalBinds, typeAppErr+                        , checkUnusedRecordWildcard )+import GHC.Rename.Unbound ( reportUnboundName )+import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName )+import GHC.Rename.Types+import GHC.Rename.Pat+import DynFlags+import PrelNames++import BasicTypes+import Name+import NameSet+import RdrName+import UniqSet+import Data.List+import Util+import ListSetOps       ( removeDups )+import ErrUtils+import Outputable+import SrcLoc+import FastString+import Control.Monad+import TysWiredIn       ( nilDataConName )+import qualified GHC.LanguageExtensions as LangExt++import Data.Ord+import Data.Array+import qualified Data.List.NonEmpty as NE++{-+************************************************************************+*                                                                      *+\subsubsection{Expressions}+*                                                                      *+************************************************************************+-}++rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)+rnExprs ls = rnExprs' ls emptyUniqSet+ where+  rnExprs' [] acc = return ([], acc)+  rnExprs' (expr:exprs) acc =+   do { (expr', fvExpr) <- rnLExpr expr+        -- Now we do a "seq" on the free vars because typically it's small+        -- or empty, especially in very long lists of constants+      ; let  acc' = acc `plusFV` fvExpr+      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'+      ; return (expr':exprs', fvExprs) }++-- Variables. We look up the variable and return the resulting name.++rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)+rnLExpr = wrapLocFstM rnExpr++rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)++finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)+-- Separated from rnExpr because it's also used+-- when renaming infix expressions+finishHsVar (L l name)+ = do { this_mod <- getModule+      ; when (nameIsLocalOrFrom this_mod name) $+        checkThLocalName name+      ; return (HsVar noExtField (L l name), unitFV name) }++rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)+rnUnboundVar v+ = do { if isUnqual v+        then -- Treat this as a "hole"+             -- Do not fail right now; instead, return HsUnboundVar+             -- and let the type checker report the error+             return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)++        else -- Fail immediately (qualified name)+             do { n <- reportUnboundName v+                ; return (HsVar noExtField (noLoc n), emptyFVs) } }++rnExpr (HsVar _ (L l v))+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v+       ; dflags <- getDynFlags+       ; case mb_name of {+           Nothing -> rnUnboundVar v ;+           Just (Left name)+              | name == nilDataConName -- Treat [] as an ExplicitList, so that+                                       -- OverloadedLists works correctly+                                       -- Note [Empty lists] in GHC.Hs.Expr+              , xopt LangExt.OverloadedLists dflags+              -> rnExpr (ExplicitList noExtField Nothing [])++              | otherwise+              -> finishHsVar (L l name) ;+            Just (Right [s]) ->+              return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ;+           Just (Right fs@(_:_:_)) ->+              return ( HsRecFld noExtField (Ambiguous noExtField (L l v))+                     , mkFVs fs);+           Just (Right [])         -> panic "runExpr/HsVar" } }++rnExpr (HsIPVar x v)+  = return (HsIPVar x v, emptyFVs)++rnExpr (HsUnboundVar x v)+  = return (HsUnboundVar x v, emptyFVs)++rnExpr (HsOverLabel x _ v)+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if rebindable_on+         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))+                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }+         else return (HsOverLabel x Nothing v, emptyFVs) }++rnExpr (HsLit x lit@(HsString src s))+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings+       ; if opt_OverloadedStrings then+            rnExpr (HsOverLit x (mkHsIsString src s))+         else do {+            ; rnLit lit+            ; return (HsLit x (convertLit lit), emptyFVs) } }++rnExpr (HsLit x lit)+  = do { rnLit lit+       ; return (HsLit x(convertLit lit), emptyFVs) }++rnExpr (HsOverLit x lit)+  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]+       ; case mb_neg of+              Nothing -> return (HsOverLit x lit', fvs)+              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))+                                 , fvs ) }++rnExpr (HsApp x fun arg)+  = do { (fun',fvFun) <- rnLExpr fun+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }++rnExpr (HsAppType x fun arg)+  = do { type_app <- xoptM LangExt.TypeApplications+       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg+       ; (fun',fvFun) <- rnLExpr fun+       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg+       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }++rnExpr (OpApp _ e1 op e2)+  = do  { (e1', fv_e1) <- rnLExpr e1+        ; (e2', fv_e2) <- rnLExpr e2+        ; (op', fv_op) <- rnLExpr op++        -- Deal with fixity+        -- When renaming code synthesised from "deriving" declarations+        -- we used to avoid fixity stuff, but we can't easily tell any+        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv+        -- should prevent bad things happening.+        ; fixity <- case op' of+              L _ (HsVar _ (L _ n)) -> lookupFixityRn n+              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f+              _ -> return (Fixity NoSourceText minPrecedence InfixL)+                   -- c.f. lookupFixity for unbound++        ; final_e <- mkOpAppRn e1' op' fixity e2'+        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }++rnExpr (NegApp _ e _)+  = do { (e', fv_e)         <- rnLExpr e+       ; (neg_name, fv_neg) <- lookupSyntaxName negateName+       ; final_e            <- mkNegAppRn e' neg_name+       ; return (final_e, fv_e `plusFV` fv_neg) }++------------------------------------------+-- Template Haskell extensions+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body++rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice++---------------------------------------------+--      Sections+-- See Note [Parsing sections] in Parser.y+rnExpr (HsPar x (L loc (section@(SectionL {}))))+  = do  { (section', fvs) <- rnSection section+        ; return (HsPar x (L loc section'), fvs) }++rnExpr (HsPar x (L loc (section@(SectionR {}))))+  = do  { (section', fvs) <- rnSection section+        ; return (HsPar x (L loc section'), fvs) }++rnExpr (HsPar x e)+  = do  { (e', fvs_e) <- rnLExpr e+        ; return (HsPar x e', fvs_e) }++rnExpr expr@(SectionL {})+  = do  { addErr (sectionErr expr); rnSection expr }+rnExpr expr@(SectionR {})+  = do  { addErr (sectionErr expr); rnSection expr }++---------------------------------------------+rnExpr (HsPragE x prag expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }+  where+    rn_prag :: HsPragE GhcPs -> HsPragE GhcRn+    rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann+    rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl+    rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo+    rn_prag (XHsPragE x) = noExtCon x++rnExpr (HsLam x matches)+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches+       ; return (HsLam x matches', fvMatch) }++rnExpr (HsLamCase x matches)+  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches+       ; return (HsLamCase x matches', fvs_ms) }++rnExpr (HsCase x expr matches)+  = do { (new_expr, e_fvs) <- rnLExpr expr+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches+       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }++rnExpr (HsLet x (L l binds) expr)+  = rnLocalBindsAndThen binds $ \binds' _ -> do+      { (expr',fvExpr) <- rnLExpr expr+      ; return (HsLet x (L l binds') expr', fvExpr) }++rnExpr (HsDo x do_or_lc (L l stmts))+  = do  { ((stmts', _), fvs) <-+           rnStmtsWithPostProcessing do_or_lc rnLExpr+             postProcessStmtsForApplicativeDo stmts+             (\ _ -> return ((), emptyFVs))+        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }++rnExpr (ExplicitList x _  exps)+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists+        ; (exps', fvs) <- rnExprs exps+        ; if opt_OverloadedLists+           then do {+            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName+            ; return (ExplicitList x (Just from_list_n_name) exps'+                     , fvs `plusFV` fvs') }+           else+            return  (ExplicitList x Nothing exps', fvs) }++rnExpr (ExplicitTuple x tup_args boxity)+  = do { checkTupleSection tup_args+       ; checkTupSize (length tup_args)+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args+       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }+  where+    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e+                                      ; return (L l (Present x e'), fvs) }+    rnTupArg (L l (Missing _)) = return (L l (Missing noExtField)+                                        , emptyFVs)+    rnTupArg (L _ (XTupArg nec)) = noExtCon nec++rnExpr (ExplicitSum x alt arity expr)+  = do { (expr', fvs) <- rnLExpr expr+       ; return (ExplicitSum x alt arity expr', fvs) }++rnExpr (RecordCon { rcon_con_name = con_id+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds+       ; (flds', fvss) <- mapAndUnzipM rn_field flds+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }+       ; return (RecordCon { rcon_ext = noExtField+                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }+  where+    mk_hs_var l n = HsVar noExtField (L l n)+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }++rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })+  = do  { (expr', fvExpr) <- rnLExpr expr+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds+        ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr'+                            , rupd_flds = rbinds' }+                 , fvExpr `plusFV` fvRbinds) }++rnExpr (ExprWithTySig _ expr pty)+  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $+                             rnLExpr expr+        ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }++rnExpr (HsIf x _ p b1 b2)+  = do { (p', fvP) <- rnLExpr p+       ; (b1', fvB1) <- rnLExpr b1+       ; (b2', fvB2) <- rnLExpr b2+       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }++rnExpr (HsMultiIf x alts)+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts+       -- ; return (HsMultiIf ty alts', fvs) }+       ; return (HsMultiIf x alts', fvs) }++rnExpr (ArithSeq x _ seq)+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists+       ; (new_seq, fvs) <- rnArithSeq seq+       ; if opt_OverloadedLists+           then do {+            ; (from_list_name, fvs') <- lookupSyntaxName fromListName+            ; return (ArithSeq x (Just from_list_name) new_seq+                     , fvs `plusFV` fvs') }+           else+            return (ArithSeq x Nothing new_seq, fvs) }++{-+************************************************************************+*                                                                      *+        Static values+*                                                                      *+************************************************************************++For the static form we check that it is not used in splices.+We also collect the free variables of the term which come from+this module. See Note [Grand plan for static forms] in StaticPtrTable.+-}++rnExpr e@(HsStatic _ expr) = do+    -- Normally, you wouldn't be able to construct a static expression without+    -- first enabling -XStaticPointers in the first place, since that extension+    -- is what makes the parser treat `static` as a keyword. But this is not a+    -- sufficient safeguard, as one can construct static expressions by another+    -- mechanism: Template Haskell (see #14204). To ensure that GHC is+    -- absolutely prepared to cope with static forms, we check for+    -- -XStaticPointers here as well.+    unlessXOptM LangExt.StaticPointers $+      addErr $ hang (text "Illegal static expression:" <+> ppr e)+                  2 (text "Use StaticPointers to enable this extension")+    (expr',fvExpr) <- rnLExpr expr+    stage <- getStage+    case stage of+      Splice _ -> addErr $ sep+             [ text "static forms cannot be used in splices:"+             , nest 2 $ ppr e+             ]+      _ -> return ()+    mod <- getModule+    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr+    return (HsStatic fvExpr' expr', fvExpr)++{-+************************************************************************+*                                                                      *+        Arrow notation+*                                                                      *+************************************************************************+-}++rnExpr (HsProc x pat body)+  = newArrowScope $+    rnPat ProcExpr pat $ \ pat' -> do+      { (body',fvBody) <- rnCmdTop body+      ; return (HsProc x pat' body', fvBody) }++rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)+        -- HsWrap++----------------------+-- See Note [Parsing sections] in Parser.y+rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnSection section@(SectionR x op expr)+  = do  { (op', fvs_op)     <- rnLExpr op+        ; (expr', fvs_expr) <- rnLExpr expr+        ; checkSectionPrec InfixR section op' expr'+        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }++rnSection section@(SectionL x expr op)+  = do  { (expr', fvs_expr) <- rnLExpr expr+        ; (op', fvs_op)     <- rnLExpr op+        ; checkSectionPrec InfixL section op' expr'+        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }++rnSection other = pprPanic "rnSection" (ppr other)++{-+************************************************************************+*                                                                      *+        Arrow commands+*                                                                      *+************************************************************************+-}++rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)+rnCmdArgs [] = return ([], emptyFVs)+rnCmdArgs (arg:args)+  = do { (arg',fvArg) <- rnCmdTop arg+       ; (args',fvArgs) <- rnCmdArgs args+       ; return (arg':args', fvArg `plusFV` fvArgs) }++rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)+rnCmdTop = wrapLocFstM rnCmdTop'+ where+  rnCmdTop' (HsCmdTop _ cmd)+   = do { (cmd', fvCmd) <- rnLCmd cmd+        ; let cmd_names = [arrAName, composeAName, firstAName] +++                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))+        -- Generate the rebindable syntax for the monad+        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names++        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',+                  fvCmd `plusFV` cmd_fvs) }+  rnCmdTop' (XCmdTop nec) = noExtCon nec++rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)+rnLCmd = wrapLocFstM rnCmd++rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)++rnCmd (HsCmdArrApp x arrow arg ho rtl)+  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsCmdArrApp x arrow' arg' ho rtl,+                 fvArrow `plusFV` fvArg) }+  where+    select_arrow_scope tc = case ho of+        HsHigherOrderApp -> tc+        HsFirstOrderApp  -> escapeArrowScope tc+        -- See Note [Escaping the arrow scope] in TcRnTypes+        -- Before renaming 'arrow', use the environment of the enclosing+        -- proc for the (-<) case.+        -- Local bindings, inside the enclosing proc, are not in scope+        -- inside 'arrow'.  In the higher-order case (-<<), they are.++-- infix form+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])+  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)+       ; let L _ (HsVar _ (L _ op_name)) = op'+       ; (arg1',fv_arg1) <- rnCmdTop arg1+       ; (arg2',fv_arg2) <- rnCmdTop arg2+        -- Deal with fixity+       ; fixity <- lookupFixityRn op_name+       ; final_e <- mkOpFormRn arg1' op' fixity arg2'+       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }++rnCmd (HsCmdArrForm x op f fixity cmds)+  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)+       ; (cmds',fvCmds) <- rnCmdArgs cmds+       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }++rnCmd (HsCmdApp x fun arg)+  = do { (fun',fvFun) <- rnLCmd  fun+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }++rnCmd (HsCmdLam x matches)+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches+       ; return (HsCmdLam x matches', fvMatch) }++rnCmd (HsCmdPar x e)+  = do  { (e', fvs_e) <- rnLCmd e+        ; return (HsCmdPar x e', fvs_e) }++rnCmd (HsCmdCase x expr matches)+  = do { (new_expr, e_fvs) <- rnLExpr expr+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches+       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }++rnCmd (HsCmdIf x _ p b1 b2)+  = do { (p', fvP) <- rnLExpr p+       ; (b1', fvB1) <- rnLCmd b1+       ; (b2', fvB2) <- rnLCmd b2+       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}++rnCmd (HsCmdLet x (L l binds) cmd)+  = rnLocalBindsAndThen binds $ \ binds' _ -> do+      { (cmd',fvExpr) <- rnLCmd cmd+      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }++rnCmd (HsCmdDo x (L l stmts))+  = do  { ((stmts', _), fvs) <-+            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))+        ; return ( HsCmdDo x (L l stmts'), fvs ) }++rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)+rnCmd     (XCmd nec)     = noExtCon nec++---------------------------------------------------+type CmdNeeds = FreeVars        -- Only inhabitants are+                                --      appAName, choiceAName, loopAName++-- find what methods the Cmd needs (loop, choice, apply)+methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds+methodNamesLCmd = methodNamesCmd . unLoc++methodNamesCmd :: HsCmd GhcRn -> CmdNeeds++methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)+  = emptyFVs+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)+  = unitFV appAName+methodNamesCmd (HsCmdArrForm {}) = emptyFVs+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd++methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c++methodNamesCmd (HsCmdIf _ _ _ c1 c2)+  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName++methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c+methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts+methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c+methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match++methodNamesCmd (HsCmdCase _ _ matches)+  = methodNamesMatch matches `addOneFV` choiceAName++methodNamesCmd (XCmd nec) = noExtCon nec++--methodNamesCmd _ = emptyFVs+   -- Other forms can't occur in commands, but it's not convenient+   -- to error here so we just do what's convenient.+   -- The type checker will complain later++---------------------------------------------------+methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars+methodNamesMatch (MG { mg_alts = L _ ms })+  = plusFVs (map do_one ms)+ where+    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss+    do_one (L _ (XMatch nec)) = noExtCon nec+methodNamesMatch (XMatchGroup nec) = noExtCon nec++-------------------------------------------------+-- gaw 2004+methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)+methodNamesGRHSs (XGRHSs nec) = noExtCon nec++-------------------------------------------------++methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs+methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec++---------------------------------------------------+methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)++---------------------------------------------------+methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars+methodNamesLStmt = methodNamesStmt . unLoc++methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars+methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd+methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd+methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd+methodNamesStmt (RecStmt { recS_stmts = stmts }) =+  methodNamesStmts stmts `addOneFV` loopAName+methodNamesStmt (LetStmt {})                   = emptyFVs+methodNamesStmt (ParStmt {})                   = emptyFVs+methodNamesStmt (TransStmt {})                 = emptyFVs+methodNamesStmt ApplicativeStmt{}              = emptyFVs+   -- ParStmt and TransStmt can't occur in commands, but it's not+   -- convenient to error here so we just do what's convenient+methodNamesStmt (XStmtLR nec) = noExtCon nec++{-+************************************************************************+*                                                                      *+        Arithmetic sequences+*                                                                      *+************************************************************************+-}++rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)+rnArithSeq (From expr)+ = do { (expr', fvExpr) <- rnLExpr expr+      ; return (From expr', fvExpr) }++rnArithSeq (FromThen expr1 expr2)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }++rnArithSeq (FromTo expr1 expr2)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }++rnArithSeq (FromThenTo expr1 expr2 expr3)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; (expr3', fvExpr3) <- rnLExpr expr3+      ; return (FromThenTo expr1' expr2' expr3',+                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }++{-+************************************************************************+*                                                                      *+\subsubsection{@Stmt@s: in @do@ expressions}+*                                                                      *+************************************************************************+-}++{-+Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both ApplicativeDo and RecursiveDo need to create tuples not+present in the source text.++For ApplicativeDo we create:++  (a,b,c) <- (\c b a -> (a,b,c)) <$>++For RecursiveDo we create:++  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))++The order of the components in those tuples needs to be stable+across recompilations, otherwise they can get optimized differently+and we end up with incompatible binaries.+To get a stable order we use nameSetElemsStable.+See Note [Deterministic UniqFM] to learn more about nondeterminism.+-}++-- | Rename some Stmts+rnStmts :: Outputable (body GhcPs)+        => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+           -- ^ How to rename the body of each statement (e.g. rnLExpr)+        -> [LStmt GhcPs (Located (body GhcPs))]+           -- ^ Statements+        -> ([Name] -> RnM (thing, FreeVars))+           -- ^ if these statements scope over something, this renames it+           -- and returns the result.+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts++-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts+rnStmtsWithPostProcessing+        :: Outputable (body GhcPs)+        => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+           -- ^ How to rename the body of each statement (e.g. rnLExpr)+        -> (HsStmtContext Name+              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]+              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))+           -- ^ postprocess the statements+        -> [LStmt GhcPs (Located (body GhcPs))]+           -- ^ Statements+        -> ([Name] -> RnM (thing, FreeVars))+           -- ^ if these statements scope over something, this renames it+           -- and returns the result.+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside+ = do { ((stmts', thing), fvs) <-+          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside+      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'+      ; return ((pp_stmts, thing), fvs `plusFV` fvs')+      }++-- | maybe rearrange statements according to the ApplicativeDo transformation+postProcessStmtsForApplicativeDo+  :: HsStmtContext Name+  -> [(ExprLStmt GhcRn, FreeVars)]+  -> RnM ([ExprLStmt GhcRn], FreeVars)+postProcessStmtsForApplicativeDo ctxt stmts+  = do {+       -- rearrange the statements using ApplicativeStmt if+       -- -XApplicativeDo is on.  Also strip out the FreeVars attached+       -- to each Stmt body.+         ado_is_on <- xoptM LangExt.ApplicativeDo+       ; let is_do_expr | DoExpr <- ctxt = True+                        | otherwise = False+       -- don't apply the transformation inside TH brackets, because+       -- DsMeta does not handle ApplicativeDo.+       ; in_th_bracket <- isBrackStage <$> getStage+       ; if ado_is_on && is_do_expr && not in_th_bracket+            then do { traceRn "ppsfa" (ppr stmts)+                    ; rearrangeForApplicativeDo ctxt stmts }+            else noPostProcessStmts ctxt stmts }++-- | strip the FreeVars annotations from statements+noPostProcessStmts+  :: HsStmtContext Name+  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]+  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)+noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)+++rnStmtsWithFreeVars :: Outputable (body GhcPs)+        => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> [LStmt GhcPs (Located (body GhcPs))]+        -> ([Name] -> RnM (thing, FreeVars))+        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)+               , FreeVars)+-- Each Stmt body is annotated with its FreeVars, so that+-- we can rearrange statements for ApplicativeDo.+--+-- Variables bound by the Stmts, and mentioned in thing_inside,+-- do not appear in the result FreeVars++rnStmtsWithFreeVars ctxt _ [] thing_inside+  = do { checkEmptyStmts ctxt+       ; (thing, fvs) <- thing_inside []+       ; return (([], thing), fvs) }++rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo+  = -- Behave like do { rec { ...all but last... }; last }+    do { ((stmts1, (stmts2, thing)), fvs)+           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->+              do { last_stmt' <- checkLastStmt MDoExpr last_stmt+                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }+        ; return (((stmts1 ++ stmts2), thing), fvs) }+  where+    Just (all_but_last, last_stmt) = snocView stmts++rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside+  | null lstmts+  = setSrcSpan loc $+    do { lstmt' <- checkLastStmt ctxt lstmt+       ; rnStmt ctxt rnBody lstmt' thing_inside }++  | otherwise+  = do { ((stmts1, (stmts2, thing)), fvs)+            <- setSrcSpan loc                         $+               do { checkStmt ctxt lstmt+                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->+                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->+                    thing_inside (bndrs1 ++ bndrs2) }+        ; return (((stmts1 ++ stmts2), thing), fvs) }++----------------------++{-+Note [Failing pattern matches in Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Many things desugar to HsStmts including monadic things like `do` and `mdo`+statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an+exhaustive list). How we deal with pattern match failure is context-dependent.++ * In the case of list comprehensions and pattern guards we don't need any 'fail'+   function; the desugarer ignores the fail function field of 'BindStmt' entirely.+ * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo+   expressions) we want pattern match failure to be desugared to the appropriate+   'fail' function (either that of Monad or MonadFail, depending on whether+   -XMonadFailDesugaring is enabled.)++At one point we failed to make this distinction, leading to #11216.+-}++rnStmt :: Outputable (body GhcPs)+       => HsStmtContext Name+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+          -- ^ How to rename the body of the statement+       -> LStmt GhcPs (Located (body GhcPs))+          -- ^ The statement+       -> ([Name] -> RnM (thing, FreeVars))+          -- ^ Rename the stuff that this statement scopes over+       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)+              , FreeVars)+-- Variables bound by the Stmt, and mentioned in thing_inside,+-- do not appear in the result FreeVars++rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+        ; (ret_op, fvs1) <- if isMonadCompContext ctxt+                            then lookupStmtName ctxt returnMName+                            else return (noSyntaxExpr, emptyFVs)+                            -- The 'return' in a LastStmt is used only+                            -- for MonadComp; and we don't want to report+                            -- "non in scope: return" in other cases+                            -- #15607++        ; (thing,  fvs3) <- thing_inside []+        ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)]+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }++rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName++        ; (guard_op, fvs2) <- if isComprehensionContext ctxt+                              then lookupStmtName ctxt guardMName+                              else return (noSyntaxExpr, emptyFVs)+                              -- Only list/monad comprehensions use 'guard'+                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]+                              -- Here "gd" is a guard++        ; (thing, fvs3)    <- thing_inside []+        ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)]+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }++rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+                -- The binders do not scope over the expression+        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName++        ; (fail_op, fvs2) <- monadFailOp pat ctxt++        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do+        { (thing, fvs3) <- thing_inside (collectPatBinders pat')+        ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op)+                     , fv_expr )]+                  , thing),+                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}+       -- fv_expr shouldn't really be filtered by the rnPatsAndThen+        -- but it does not matter because the names are unique++rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside+  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do+        { (thing, fvs) <- thing_inside (collectLocalBinders binds')+        ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing)+                 , fvs) }  }++rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside+  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName+        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName+        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName+        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op+                                                , recS_mfix_fn = mfix_op+                                                , recS_bind_fn = bind_op }++        -- Step1: Bring all the binders of the mdo into scope+        -- (Remember that this also removes the binders from the+        -- finally-returned free-vars.)+        -- And rename each individual stmt, making a+        -- singleton segment.  At this stage the FwdRefs field+        -- isn't finished: it's empty for all except a BindStmt+        -- for which it's the fwd refs within the bind itself+        -- (This set may not be empty, because we're in a recursive+        -- context.)+        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do+        { let bndrs = nameSetElemsStable $+                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))+                              emptyNameSet+                              segs+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+        ; (thing, fvs_later) <- thing_inside bndrs+        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+        -- We aren't going to try to group RecStmts with+        -- ApplicativeDo, so attaching empty FVs is fine.+        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)+                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }++rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside+  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName+        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName+        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName+        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside+        ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }++rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form+                              , trS_using = using })) thing_inside+  = do { -- Rename the 'using' expression in the context before the transform is begun+         (using', fvs1) <- rnLExpr using++         -- Rename the stmts and the 'by' expression+         -- Keep track of the variables mentioned in the 'by' expression+       ; ((stmts', (by', used_bndrs, thing)), fvs2)+             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->+                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by+                   ; (thing, fvs_thing) <- thing_inside bndrs+                   ; let fvs = fvs_by `plusFV` fvs_thing+                         used_bndrs = filter (`elemNameSet` fvs) bndrs+                         -- The paper (Fig 5) has a bug here; we must treat any free variable+                         -- of the "thing inside", **or of the by-expression**, as used+                   ; return ((by', used_bndrs, thing), fvs) }++       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions+       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName+       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName+       ; (fmap_op,   fvs5) <- case form of+                                ThenForm -> return (noExpr, emptyFVs)+                                _        -> lookupStmtNamePoly ctxt fmapName++       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3+                             `plusFV` fvs4 `plusFV` fvs5+             bndr_map = used_bndrs `zip` used_bndrs+             -- See Note [TransStmt binder map] in GHC.Hs.Expr++       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)+       ; return (([(L loc (TransStmt { trS_ext = noExtField+                                    , trS_stmts = stmts', trS_bndrs = bndr_map+                                    , trS_by = by', trS_using = using', trS_form = form+                                    , trS_ret = return_op, trS_bind = bind_op+                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }++rnStmt _ _ (L _ ApplicativeStmt{}) _ =+  panic "rnStmt: ApplicativeStmt"++rnStmt _ _ (L _ (XStmtLR nec)) _ =+  noExtCon nec++rnParallelStmts :: forall thing. HsStmtContext Name+                -> SyntaxExpr GhcRn+                -> [ParStmtBlock GhcPs GhcPs]+                -> ([Name] -> RnM (thing, FreeVars))+                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)+-- Note [Renaming parallel Stmts]+rnParallelStmts ctxt return_op segs thing_inside+  = do { orig_lcl_env <- getLocalRdrEnv+       ; rn_segs orig_lcl_env [] segs }+  where+    rn_segs :: LocalRdrEnv+            -> [Name] -> [ParStmtBlock GhcPs GhcPs]+            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)+    rn_segs _ bndrs_so_far []+      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far+           ; mapM_ dupErr dups+           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')+           ; return (([], thing), fvs) }++    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)+      = do { ((stmts', (used_bndrs, segs', thing)), fvs)+                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->+                       setLocalRdrEnv env       $ do+                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs+                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs+                       ; return ((used_bndrs, segs', thing), fvs) }++           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op+           ; return ((seg':segs', thing), fvs) }+    rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec++    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2+    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"+                    <+> quotes (ppr (NE.head vs)))++lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)+-- Like lookupSyntaxName, but respects contexts+lookupStmtName ctxt n+  | rebindableContext ctxt+  = lookupSyntaxName n+  | otherwise+  = return (mkRnSyntaxExpr n, emptyFVs)++lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)+lookupStmtNamePoly ctxt name+  | rebindableContext ctxt+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if rebindable_on+         then do { fm <- lookupOccRn (nameRdrName name)+                 ; return (HsVar noExtField (noLoc fm), unitFV fm) }+         else not_rebindable }+  | otherwise+  = not_rebindable+  where+    not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs)++-- | Is this a context where we respect RebindableSyntax?+-- but ListComp are never rebindable+-- Neither is ArrowExpr, which has its own desugarer in DsArrows+rebindableContext :: HsStmtContext Name -> Bool+rebindableContext ctxt = case ctxt of+  ListComp        -> False+  ArrowExpr       -> False+  PatGuard {}     -> False++  DoExpr          -> True+  MDoExpr         -> True+  MonadComp       -> True+  GhciStmtCtxt    -> True   -- I suppose?++  ParStmtCtxt   c -> rebindableContext c     -- Look inside to+  TransStmtCtxt c -> rebindableContext c     -- the parent context++{-+Note [Renaming parallel Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Renaming parallel statements is painful.  Given, say+     [ a+c | a <- as, bs <- bss+           | c <- bs, a <- ds ]+Note that+  (a) In order to report "Defined but not used" about 'bs', we must+      rename each group of Stmts with a thing_inside whose FreeVars+      include at least {a,c}++  (b) We want to report that 'a' is illegally bound in both branches++  (c) The 'bs' in the second group must obviously not be captured by+      the binding in the first group++To satisfy (a) we nest the segements.+To satisfy (b) we check for duplicates just before thing_inside.+To satisfy (c) we reset the LocalRdrEnv each time.++************************************************************************+*                                                                      *+\subsubsection{mdo expressions}+*                                                                      *+************************************************************************+-}++type FwdRefs = NameSet+type Segment stmts = (Defs,+                      Uses,     -- May include defs+                      FwdRefs,  -- A subset of uses that are+                                --   (a) used before they are bound in this segment, or+                                --   (b) used here, and bound in subsequent segments+                      stmts)    -- Either Stmt or [Stmt]+++-- wrapper that does both the left- and right-hand sides+rnRecStmtsAndThen :: Outputable (body GhcPs) =>+                     (Located (body GhcPs)+                  -> RnM (Located (body GhcRn), FreeVars))+                  -> [LStmt GhcPs (Located (body GhcPs))]+                         -- assumes that the FreeVars returned includes+                         -- the FreeVars of the Segments+                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]+                      -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+rnRecStmtsAndThen rnBody s cont+  = do  { -- (A) Make the mini fixity env for all of the stmts+          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)++          -- (B) Do the LHSes+        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s++          --    ...bring them and their fixities into scope+        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)+              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)+              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)+              implicit_uses = mkNameSet $ concatMap snd $ rec_uses+        ; bindLocalNamesFV bound_names $+          addLocalFixities fix_env bound_names $ do++          -- (C) do the right-hand-sides and thing-inside+        { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv+        ; (res, fvs) <- cont segs+        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))+                rec_uses+        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)+        ; return (res, fvs) }}++-- get all the fixity decls in any Let stmt+collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]+collectRecStmtsFixities l =+    foldr (\ s -> \acc -> case s of+            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->+              foldr (\ sig -> \ acc -> case sig of+                                         (L loc (FixSig _ s)) -> (L loc s) : acc+                                         _ -> acc) acc sigs+            _ -> acc) [] l++-- left-hand sides++rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv+                -> LStmt GhcPs body+                   -- rename LHS, and return its FVs+                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,+                   -- so we don't bother to compute it accurately in the other cases+                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]++rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))+  = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]++rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))+  = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]++rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))+  = do+      -- should the ctxt be MDo instead?+      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat+      return [(L loc (BindStmt noExtField pat' body a b), fv_pat)]++rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))+  = failWith (badIpBinds (text "an mdo expression") binds)++rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))+    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds+         return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))),+                 -- Warning: this is bogus; see function invariant+                 emptyFVs+                 )]++-- XXX Do we need to do something with the return and mfix names?+rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec+    = rn_rec_stmts_lhs fix_env stmts++rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))+  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))))+  = noExtCon nec+rn_rec_stmt_lhs _ (L _ (XStmtLR nec))+  = noExtCon nec++rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv+                 -> [LStmt GhcPs body]+                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]+rn_rec_stmts_lhs fix_env stmts+  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts+       ; let boundNames = collectLStmtsBinders (map fst ls)+            -- First do error checking: we need to check for dups here because we+            -- don't bind all of the variables from the Stmt at once+            -- with bindLocatedLocals.+       ; checkDupNames boundNames+       ; return ls }+++-- right-hand-sides++rn_rec_stmt :: (Outputable (body GhcPs)) =>+               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+            -> [Name]+            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)+            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]+        -- Rename a Stmt that is inside a RecStmt (or mdo)+        -- Assumes all binders are already in scope+        -- Turns each stmt into a singleton Stmt+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)+  = do  { (body', fv_expr) <- rnBody body+        ; (ret_op, fvs1)   <- lookupSyntaxName returnMName+        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,+                   L loc (LastStmt noExtField body' noret ret_op))] }++rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)+  = do { (body', fvs) <- rnBody body+       ; (then_op, fvs1) <- lookupSyntaxName thenMName+       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,+                 L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }++rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)+  = do { (body', fv_expr) <- rnBody body+       ; (bind_op, fvs1) <- lookupSyntaxName bindMName++       ; (fail_op, fvs2) <- getMonadFailOp++       ; let bndrs = mkNameSet (collectPatBinders pat')+             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2+       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,+                  L loc (BindStmt noExtField pat' body' bind_op fail_op))] }++rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)+  = failWith (badIpBinds (text "an mdo expression") binds)++rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)+  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'+           -- fixities and unused are handled above in rnRecStmtsAndThen+       ; let fvs = allUses du_binds+       ; return [(duDefs du_binds, fvs, emptyNameSet,+                 L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] }++-- no RecStmt case because they get flattened above when doing the LHSes+rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)+  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)++rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _)+  = noExtCon nec++rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)+  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"++rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)+  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)++rn_rec_stmt _ _ (L _ (XStmtLR nec), _)+  = noExtCon nec++rn_rec_stmts :: Outputable (body GhcPs) =>+                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+             -> [Name]+             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]+             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]+rn_rec_stmts rnBody bndrs stmts+  = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts+       ; return (concat segs_s) }++---------------------------------------------+segmentRecStmts :: SrcSpan -> HsStmtContext Name+                -> Stmt GhcRn body+                -> [Segment (LStmt GhcRn body)] -> FreeVars+                -> ([LStmt GhcRn body], FreeVars)++segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+  | null segs+  = ([], fvs_later)++  | MDoExpr <- ctxt+  = segsToStmts empty_rec_stmt grouped_segs fvs_later+               -- Step 4: Turn the segments into Stmts+                --         Use RecStmt when and only when there are fwd refs+                --         Also gather up the uses from the end towards the+                --         start, so we can tell the RecStmt which things are+                --         used 'after' the RecStmt++  | otherwise+  = ([ L loc $+       empty_rec_stmt { recS_stmts = ss+                      , recS_later_ids = nameSetElemsStable+                                           (defs `intersectNameSet` fvs_later)+                      , recS_rec_ids   = nameSetElemsStable+                                           (defs `intersectNameSet` uses) }]+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+    , uses `plusFV` fvs_later)++  where+    (defs_s, uses_s, _, ss) = unzip4 segs+    defs = plusFVs defs_s+    uses = plusFVs uses_s++                -- Step 2: Fill in the fwd refs.+                --         The segments are all singletons, but their fwd-ref+                --         field mentions all the things used by the segment+                --         that are bound after their use+    segs_w_fwd_refs = addFwdRefs segs++                -- Step 3: Group together the segments to make bigger segments+                --         Invariant: in the result, no segment uses a variable+                --                    bound in a later segment+    grouped_segs = glomSegments ctxt segs_w_fwd_refs++----------------------------+addFwdRefs :: [Segment a] -> [Segment a]+-- So far the segments only have forward refs *within* the Stmt+--      (which happens for bind:  x <- ...x...)+-- This function adds the cross-seg fwd ref info++addFwdRefs segs+  = fst (foldr mk_seg ([], emptyNameSet) segs)+  where+    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)+        = (new_seg : segs, all_defs)+        where+          new_seg = (defs, uses, new_fwds, stmts)+          all_defs = later_defs `unionNameSet` defs+          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)+                -- Add the downstream fwd refs here++{-+Note [Segmenting mdo]+~~~~~~~~~~~~~~~~~~~~~+NB. June 7 2012: We only glom segments that appear in an explicit mdo;+and leave those found in "do rec"'s intact.  See+https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion+leading to this design choice.  Hence the test in segmentRecStmts.++Note [Glomming segments]+~~~~~~~~~~~~~~~~~~~~~~~~+Glomming the singleton segments of an mdo into minimal recursive groups.++At first I thought this was just strongly connected components, but+there's an important constraint: the order of the stmts must not change.++Consider+     mdo { x <- ...y...+           p <- z+           y <- ...x...+           q <- x+           z <- y+           r <- x }++Here, the first stmt mention 'y', which is bound in the third.+But that means that the innocent second stmt (p <- z) gets caught+up in the recursion.  And that in turn means that the binding for+'z' has to be included... and so on.++Start at the tail { r <- x }+Now add the next one { z <- y ; r <- x }+Now add one more     { q <- x ; z <- y ; r <- x }+Now one more... but this time we have to group a bunch into rec+     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }+Now one more, which we can add on without a rec+     { p <- z ;+       rec { y <- ...x... ; q <- x ; z <- y } ;+       r <- x }+Finally we add the last one; since it mentions y we have to+glom it together with the first two groups+     { rec { x <- ...y...; p <- z ; y <- ...x... ;+             q <- x ; z <- y } ;+       r <- x }+-}++glomSegments :: HsStmtContext Name+             -> [Segment (LStmt GhcRn body)]+             -> [Segment [LStmt GhcRn body]]+                                  -- Each segment has a non-empty list of Stmts+-- See Note [Glomming segments]++glomSegments _ [] = []+glomSegments ctxt ((defs,uses,fwds,stmt) : segs)+        -- Actually stmts will always be a singleton+  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others+  where+    segs'            = glomSegments ctxt segs+    (extras, others) = grab uses segs'+    (ds, us, fs, ss) = unzip4 extras++    seg_defs  = plusFVs ds `plusFV` defs+    seg_uses  = plusFVs us `plusFV` uses+    seg_fwds  = plusFVs fs `plusFV` fwds+    seg_stmts = stmt : concat ss++    grab :: NameSet             -- The client+         -> [Segment a]+         -> ([Segment a],       -- Needed by the 'client'+             [Segment a])       -- Not needed by the client+        -- The result is simply a split of the input+    grab uses dus+        = (reverse yeses, reverse noes)+        where+          (noes, yeses)           = span not_needed (reverse dus)+          not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)++----------------------------------------------------+segsToStmts :: Stmt GhcRn body+                                  -- A RecStmt with the SyntaxOps filled in+            -> [Segment [LStmt GhcRn body]]+                                  -- Each Segment has a non-empty list of Stmts+            -> FreeVars           -- Free vars used 'later'+            -> ([LStmt GhcRn body], FreeVars)++segsToStmts _ [] fvs_later = ([], fvs_later)+segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later+  = ASSERT( not (null ss) )+    (new_stmt : later_stmts, later_uses `plusFV` uses)+  where+    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later+    new_stmt | non_rec   = head ss+             | otherwise = L (getLoc (head ss)) rec_stmt+    rec_stmt = empty_rec_stmt { recS_stmts     = ss+                              , recS_later_ids = nameSetElemsStable used_later+                              , recS_rec_ids   = nameSetElemsStable fwds }+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+    non_rec    = isSingleton ss && isEmptyNameSet fwds+    used_later = defs `intersectNameSet` later_uses+                                -- The ones needed after the RecStmt++{-+************************************************************************+*                                                                      *+ApplicativeDo+*                                                                      *+************************************************************************++Note [ApplicativeDo]++= Example =++For a sequence of statements++ do+     x <- A+     y <- B x+     z <- C+     return (f x y z)++We want to transform this to++  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C++It would be easy to notice that "y <- B x" and "z <- C" are+independent and do something like this:++ do+     x <- A+     (y,z) <- (,) <$> B x <*> C+     return (f x y z)++But this isn't enough! A and C were also independent, and this+transformation loses the ability to do A and C in parallel.++The algorithm works by first splitting the sequence of statements into+independent "segments", and a separate "tail" (the final statement). In+our example above, the segements would be++     [ x <- A+     , y <- B x ]++     [ z <- C ]++and the tail is:++     return (f x y z)++Then we take these segments and make an Applicative expression from them:++     (\(x,y) z -> return (f x y z))+       <$> do { x <- A; y <- B x; return (x,y) }+       <*> C++Finally, we recursively apply the transformation to each segment, to+discover any nested parallelism.++= Syntax & spec =++  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...++  stmt ::= pat <- expr+         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1+         | ...                    -- other kinds of statement (e.g. let)++  arg ::= pat <- expr+        | {stmt_1; ..; stmt_n} {var_1..var_n}++(note that in the actual implementation,the expr in a do statement is+represented by a LastStmt as the final stmt, this is just a+representational issue and may change later.)++== Transformation to introduce applicative stmts ==++ado {} tail = tail+ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'+ado {one} tail = one : tail+ado stmts tail+  | n == 1 = ado before (ado after tail)+    where (before,after) = split(stmts_1)+  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail+  where+    {stmts_1 .. stmts_n} = segments(stmts)++segments(stmts) =+  -- divide stmts into segments with no interdependencies++mkArg({pat <- expr}) = (pat <- expr)+mkArg({stmt_1; ...; stmt_n}) =+  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}++split({stmt_1; ..; stmt_n) =+  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})+  -- 1 <= i <= n+  -- i is a good place to insert a bind++== Desugaring for do ==++dsDo {} expr = expr++dsDo {pat <- rhs; stmts} expr =+   rhs >>= \pat -> dsDo stmts expr++dsDo {(arg_1 | ... | arg_n)} (return expr) =+  (\argpat (arg_1) .. argpat(arg_n) -> expr)+     <$> argexpr(arg_1)+     <*> ...+     <*> argexpr(arg_n)++dsDo {(arg_1 | ... | arg_n); stmts} expr =+  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)+     <$> argexpr(arg_1)+     <*> ...+     <*> argexpr(arg_n)++= Relevant modules in the rest of the compiler =++ApplicativeDo touches a few phases in the compiler:++* Renamer: The journey begins here in the renamer, where do-blocks are+  scheduled as outlined above and transformed into applicative+  combinators.  However, the code is still represented as a do-block+  with special forms of applicative statements. This allows us to+  recover the original do-block when e.g.  printing type errors, where+  we don't want to show any of the applicative combinators since they+  don't exist in the source code.+  See ApplicativeStmt and ApplicativeArg in HsExpr.++* Typechecker: ApplicativeDo passes through the typechecker much like any+  other form of expression. The only crux is that the typechecker has to+  be aware of the special ApplicativeDo statements in the do-notation, and+  typecheck them appropriately.+  Relevant module: TcMatches++* Desugarer: Any do-block which contains applicative statements is desugared+  as outlined above, to use the Applicative combinators.+  Relevant module: DsExpr++-}++-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and+-- 'pureName' due to @RebindableSyntax@.+data MonadNames = MonadNames { return_name, pure_name :: Name }++instance Outputable MonadNames where+  ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =+    hcat+    [text "MonadNames { return_name = "+    ,ppr return_name+    ,text ", pure_name = "+    ,ppr pure_name+    ,text "}"+    ]++-- | rearrange a list of statements using ApplicativeDoStmt.  See+-- Note [ApplicativeDo].+rearrangeForApplicativeDo+  :: HsStmtContext Name+  -> [(ExprLStmt GhcRn, FreeVars)]+  -> RnM ([ExprLStmt GhcRn], FreeVars)++rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)+rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)+rearrangeForApplicativeDo ctxt stmts0 = do+  optimal_ado <- goptM Opt_OptimalApplicativeDo+  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts+                | otherwise = mkStmtTreeHeuristic stmts+  traceRn "rearrangeForADo" (ppr stmt_tree)+  return_name <- lookupSyntaxName' returnMName+  pure_name   <- lookupSyntaxName' pureAName+  let monad_names = MonadNames { return_name = return_name+                               , pure_name   = pure_name }+  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs+  where+    (stmts,(last,last_fvs)) = findLast stmts0+    findLast [] = error "findLast"+    findLast [last] = ([],last)+    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs++-- | A tree of statements using a mixture of applicative and bind constructs.+data StmtTree a+  = StmtTreeOne a+  | StmtTreeBind (StmtTree a) (StmtTree a)+  | StmtTreeApplicative [StmtTree a]++instance Outputable a => Outputable (StmtTree a) where+  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)+  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")+                                            2 (sep [ppr x, ppr y]))+  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")+                                            2 (vcat (map ppr xs)))++flattenStmtTree :: StmtTree a -> [a]+flattenStmtTree t = go t []+ where+  go (StmtTreeOne a) as = a : as+  go (StmtTreeBind l r) as = go l (go r as)+  go (StmtTreeApplicative ts) as = foldr go as ts++type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)+type Cost = Int++-- | Turn a sequence of statements into an ExprStmtTree using a+-- heuristic algorithm.  /O(n^2)/+mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree+mkStmtTreeHeuristic [one] = StmtTreeOne one+mkStmtTreeHeuristic stmts =+  case segments stmts of+    [one] -> split one+    segs -> StmtTreeApplicative (map split segs)+ where+  split [one] = StmtTreeOne one+  split stmts =+    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)+    where (before, after) = splitSegment stmts++-- | Turn a sequence of statements into an ExprStmtTree optimally,+-- using dynamic programming.  /O(n^3)/+mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree+mkStmtTreeOptimal stmts =+  ASSERT(not (null stmts)) -- the empty case is handled by the caller;+                           -- we don't support empty StmtTrees.+  fst (arr ! (0,n))+  where+    n = length stmts - 1+    stmt_arr = listArray (0,n) stmts++    -- lazy cache of optimal trees for subsequences of the input+    arr :: Array (Int,Int) (ExprStmtTree, Cost)+    arr = array ((0,0),(n,n))+             [ ((lo,hi), tree lo hi)+             | lo <- [0..n]+             , hi <- [lo..n] ]++    -- compute the optimal tree for the sequence [lo..hi]+    tree lo hi+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)+      | otherwise =+         case segments [ stmt_arr ! i | i <- [lo..hi] ] of+           [] -> panic "mkStmtTree"+           [_one] -> split lo hi+           segs -> (StmtTreeApplicative trees, maximum costs)+             where+               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs+               (trees,costs) = unzip (map (uncurry split) (tail bounds))++    -- find the best place to split the segment [lo..hi]+    split :: Int -> Int -> (ExprStmtTree, Cost)+    split lo hi+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)+      | otherwise = (StmtTreeBind before after, c1+c2)+        where+         -- As per the paper, for a sequence s1...sn, we want to find+         -- the split with the minimum cost, where the cost is the+         -- sum of the cost of the left and right subsequences.+         --+         -- As an optimisation (also in the paper) if the cost of+         -- s1..s(n-1) is different from the cost of s2..sn, we know+         -- that the optimal solution is the lower of the two.  Only+         -- in the case that these two have the same cost do we need+         -- to do the exhaustive search.+         --+         ((before,c1),(after,c2))+           | hi - lo == 1+           = ((StmtTreeOne (stmt_arr ! lo), 1),+              (StmtTreeOne (stmt_arr ! hi), 1))+           | left_cost < right_cost+           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))+           | left_cost > right_cost+           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))+           | otherwise = minimumBy (comparing cost) alternatives+           where+             (left, left_cost) = arr ! (lo,hi-1)+             (right, right_cost) = arr ! (lo+1,hi)+             cost ((_,c1),(_,c2)) = c1 + c2+             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))+                            | k <- [lo .. hi-1] ]+++-- | Turn the ExprStmtTree back into a sequence of statements, using+-- ApplicativeStmt where necessary.+stmtTreeToStmts+  :: MonadNames+  -> HsStmtContext Name+  -> ExprStmtTree+  -> [ExprLStmt GhcRn]             -- ^ the "tail"+  -> FreeVars                     -- ^ free variables of the tail+  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,+         , FreeVars )             -- , things we needed++-- If we have a single bind, and we can do it without a join, transform+-- to an ApplicativeStmt.  This corresponds to the rule+--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs+-- In the spec, but we do it here rather than in the desugarer,+-- because we need the typechecker to typecheck the <$> form rather than+-- the bind form, which would give rise to a Monad constraint.+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _))+                tail _tail_fvs+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail+  -- See Note [ApplicativeDo and strict patterns]+  = mkApplicativeStmt ctxt [ApplicativeArgOne+                            { xarg_app_arg_one = noExtField+                            , app_arg_pattern  = pat+                            , arg_expr         = rhs+                            , is_body_stmt     = False+                            , fail_operator    = fail_op}]+                      False tail'+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))+                tail _tail_fvs+  | (False,tail') <- needJoin monad_names tail+  = mkApplicativeStmt ctxt+      [ApplicativeArgOne+       { xarg_app_arg_one = noExtField+       , app_arg_pattern  = nlWildPatName+       , arg_expr         = rhs+       , is_body_stmt     = True+       , fail_operator    = fail_op}] False tail'++stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =+  return (s : tail, emptyNameSet)++stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do+  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs+  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))+  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs+  return (stmts2, fvs1 `plusFV` fvs2)++stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do+   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees+   let (stmts', fvss) = unzip pairs+   let (need_join, tail') =+         if any hasStrictPattern trees+         then (True, tail)+         else needJoin monad_names tail++   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'+   return (stmts, unionNameSets (fvs:fvss))+ where+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))+     = return (ApplicativeArgOne+               { xarg_app_arg_one = noExtField+               , app_arg_pattern  = pat+               , arg_expr         = exp+               , is_body_stmt     = False+               , fail_operator    = fail_op+               }, emptyFVs)+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =+     return (ApplicativeArgOne+             { xarg_app_arg_one = noExtField+             , app_arg_pattern  = nlWildPatName+             , arg_expr         = exp+             , is_body_stmt     = True+             , fail_operator    = fail_op+             }, emptyFVs)+   stmtTreeArg ctxt tail_fvs tree = do+     let stmts = flattenStmtTree tree+         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)+                     `intersectNameSet` tail_fvs+         pvars = nameSetElemsStable pvarset+           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+         pat = mkBigLHsVarPatTup pvars+         tup = mkBigLHsVarTup pvars+     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset+     (mb_ret, fvs1) <-+        if | L _ ApplicativeStmt{} <- last stmts' ->+             return (unLoc tup, emptyNameSet)+           | otherwise -> do+             ret <- lookupSyntaxName' returnMName+             let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup+             return (expr, emptyFVs)+     return ( ApplicativeArgMany+              { xarg_app_arg_many = noExtField+              , app_stmts         = stmts'+              , final_expr        = mb_ret+              , bv_pattern        = pat+              }+            , fvs1 `plusFV` fvs2)+++-- | Divide a sequence of statements into segments, where no segment+-- depends on any variables defined by a statement in another segment.+segments+  :: [(ExprLStmt GhcRn, FreeVars)]+  -> [[(ExprLStmt GhcRn, FreeVars)]]+segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)+  where+    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)++    -- We would rather not have a segment that just has LetStmts in+    -- it, so combine those with an adjacent segment where possible.+    merge [] = []+    merge (seg : segs)+       = case rest of+          [] -> [(seg,all_lets)]+          ((s,s_lets):ss) | all_lets || s_lets+               -> (seg ++ s, all_lets && s_lets) : ss+          _otherwise -> (seg,all_lets) : rest+      where+        rest = merge segs+        all_lets = all (isLetStmt . fst) seg++    -- walk splits the statement sequence into segments, traversing+    -- the sequence from the back to the front, and keeping track of+    -- the set of free variables of the current segment.  Whenever+    -- this set of free variables is empty, we have a complete segment.+    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]+    walk [] = []+    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest+      where (seg,rest) = chunter fvs' stmts+            (_, fvs') = stmtRefs stmt fvs++    chunter _ [] = ([], [])+    chunter vars ((stmt,fvs) : rest)+       | not (isEmptyNameSet vars)+       || isStrictPatternBind stmt+           -- See Note [ApplicativeDo and strict patterns]+       = ((stmt,fvs) : chunk, rest')+       where (chunk,rest') = chunter vars' rest+             (pvars, evars) = stmtRefs stmt fvs+             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars+    chunter _ rest = ([], rest)++    stmtRefs stmt fvs+      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)+      | otherwise      = (pvars, fvs')+      where fvs' = fvs `intersectNameSet` allvars+            pvars = mkNameSet (collectStmtBinders (unLoc stmt))++    isStrictPatternBind :: ExprLStmt GhcRn -> Bool+    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat+    isStrictPatternBind _ = False++{-+Note [ApplicativeDo and strict patterns]++A strict pattern match is really a dependency.  For example,++do+  (x,y) <- A+  z <- B+  return C++The pattern (_,_) must be matched strictly before we do B.  If we+allowed this to be transformed into++  (\(x,y) -> \z -> C) <$> A <*> B++then it could be lazier than the standard desuraging using >>=.  See #13875+for more examples.++Thus, whenever we have a strict pattern match, we treat it as a+dependency between that statement and the following one.  The+dependency prevents those two statements from being performed "in+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we+can do with the rest of the statements in the same "do" expression.+-}++isStrictPattern :: LPat (GhcPass p) -> Bool+isStrictPattern lpat =+  case unLoc lpat of+    WildPat{}       -> False+    VarPat{}        -> False+    LazyPat{}       -> False+    AsPat _ _ p     -> isStrictPattern p+    ParPat _ p      -> isStrictPattern p+    ViewPat _ _ p   -> isStrictPattern p+    SigPat _ p _    -> isStrictPattern p+    BangPat{}       -> True+    ListPat{}       -> True+    TuplePat{}      -> True+    SumPat{}        -> True+    ConPatIn{}      -> True+    ConPatOut{}     -> True+    LitPat{}        -> True+    NPat{}          -> True+    NPlusKPat{}     -> True+    SplicePat{}     -> True+    _otherwise -> panic "isStrictPattern"++hasStrictPattern :: ExprStmtTree -> Bool+hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat+hasStrictPattern (StmtTreeOne _) = False+hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b+hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees+++isLetStmt :: LStmt a b -> Bool+isLetStmt (L _ LetStmt{}) = True+isLetStmt _ = False++-- | Find a "good" place to insert a bind in an indivisible segment.+-- This is the only place where we use heuristics.  The current+-- heuristic is to peel off the first group of independent statements+-- and put the bind after those.+splitSegment+  :: [(ExprLStmt GhcRn, FreeVars)]+  -> ( [(ExprLStmt GhcRn, FreeVars)]+     , [(ExprLStmt GhcRn, FreeVars)] )+splitSegment [one,two] = ([one],[two])+  -- there is no choice when there are only two statements; this just saves+  -- some work in a common case.+splitSegment stmts+  | Just (lets,binds,rest) <- slurpIndependentStmts stmts+  =  if not (null lets)+       then (lets, binds++rest)+       else (lets++binds, rest)+  | otherwise+  = case stmts of+      (x:xs) -> ([x],xs)+      _other -> (stmts,[])++slurpIndependentStmts+   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]+   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )+slurpIndependentStmts stmts = go [] [] emptyNameSet stmts+ where+  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt+  -- in this group, then add it to the group. We have to be careful about+  -- strict patterns though; splitSegments expects that if we return Just+  -- then we have actually done some splitting. Otherwise it will go into+  -- an infinite loop (#14163).+  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)+    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)+    = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep)+         bndrs' rest+    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)+  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this+  -- group, then move it to the beginning, so that it doesn't interfere with+  -- grouping more BindStmts.+  -- TODO: perhaps we shouldn't do this if there are any strict bindings,+  -- because we might be moving evaluation earlier.+  go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)+    = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest+  go _ []  _ _ = Nothing+  go _ [_] _ _ = Nothing+  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)++-- | Build an ApplicativeStmt, and strip the "return" from the tail+-- if necessary.+--+-- For example, if we start with+--   do x <- E1; y <- E2; return (f x y)+-- then we get+--   do (E1[x] | E2[y]); f x y+--+-- the LastStmt in this case has the return removed, but we set the+-- flag on the LastStmt to indicate this, so that we can print out the+-- original statement correctly in error messages.  It is easier to do+-- it this way rather than try to ignore the return later in both the+-- typechecker and the desugarer (I tried it that way first!).+mkApplicativeStmt+  :: HsStmtContext Name+  -> [ApplicativeArg GhcRn]             -- ^ The args+  -> Bool                               -- ^ True <=> need a join+  -> [ExprLStmt GhcRn]        -- ^ The body statements+  -> RnM ([ExprLStmt GhcRn], FreeVars)+mkApplicativeStmt ctxt args need_join body_stmts+  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName+       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName+       ; (mb_join, fvs3) <-+           if need_join then+             do { (join_op, fvs) <- lookupStmtName ctxt joinMName+                ; return (Just join_op, fvs) }+           else+             return (Nothing, emptyNameSet)+       ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField+               (zip (fmap_op : repeat ap_op) args)+               mb_join+       ; return ( applicative_stmt : body_stmts+                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }++-- | Given the statements following an ApplicativeStmt, determine whether+-- we need a @join@ or not, and remove the @return@ if necessary.+needJoin :: MonadNames+         -> [ExprLStmt GhcRn]+         -> (Bool, [ExprLStmt GhcRn])+needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg+needJoin monad_names  [L loc (LastStmt _ e _ t)]+ | Just arg <- isReturnApp monad_names e =+       (False, [L loc (LastStmt noExtField arg True t)])+needJoin _monad_names stmts = (True, stmts)++-- | @Just e@, if the expression is @return e@ or @return $ e@,+-- otherwise @Nothing@+isReturnApp :: MonadNames+            -> LHsExpr GhcRn+            -> Maybe (LHsExpr GhcRn)+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr+isReturnApp monad_names (L _ e) = case e of+  OpApp _ l op r | is_return l, is_dollar op -> Just r+  HsApp _ f arg  | is_return f               -> Just arg+  _otherwise -> Nothing+ where+  is_var f (L _ (HsPar _ e)) = is_var f e+  is_var f (L _ (HsAppType _ e _)) = is_var f e+  is_var f (L _ (HsVar _ (L _ r))) = f r+       -- TODO: I don't know how to get this right for rebindable syntax+  is_var _ _ = False++  is_return = is_var (\n -> n == return_name monad_names+                         || n == pure_name monad_names)+  is_dollar = is_var (`hasKey` dollarIdKey)++{-+************************************************************************+*                                                                      *+\subsubsection{Errors}+*                                                                      *+************************************************************************+-}++checkEmptyStmts :: HsStmtContext Name -> RnM ()+-- We've seen an empty sequence of Stmts... is that ok?+checkEmptyStmts ctxt+  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))++okEmpty :: HsStmtContext a -> Bool+okEmpty (PatGuard {}) = True+okEmpty _             = False++emptyErr :: HsStmtContext Name -> SDoc+emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"+emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"+emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt++----------------------+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name+              -> LStmt GhcPs (Located (body GhcPs))+              -> RnM (LStmt GhcPs (Located (body GhcPs)))+checkLastStmt ctxt lstmt@(L loc stmt)+  = case ctxt of+      ListComp  -> check_comp+      MonadComp -> check_comp+      ArrowExpr -> check_do+      DoExpr    -> check_do+      MDoExpr   -> check_do+      _         -> check_other+  where+    check_do    -- Expect BodyStmt, and change it to LastStmt+      = case stmt of+          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))+          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a+                                             -- LastStmt directly (unlike the parser)+          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }+    last_error = (text "The last statement in" <+> pprAStmtContext ctxt+                  <+> text "must be an expression")++    check_comp  -- Expect LastStmt; this should be enforced by the parser!+      = case stmt of+          LastStmt {} -> return lstmt+          _           -> pprPanic "checkLastStmt" (ppr lstmt)++    check_other -- Behave just as if this wasn't the last stmt+      = do { checkStmt ctxt lstmt; return lstmt }++-- Checking when a particular Stmt is ok+checkStmt :: HsStmtContext Name+          -> LStmt GhcPs (Located (body GhcPs))+          -> RnM ()+checkStmt ctxt (L _ stmt)+  = do { dflags <- getDynFlags+       ; case okStmt dflags ctxt stmt of+           IsValid        -> return ()+           NotValid extra -> addErr (msg $$ extra) }+  where+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")+             , text "in" <+> pprAStmtContext ctxt ]++pprStmtCat :: Stmt (GhcPass a) body -> SDoc+pprStmtCat (TransStmt {})     = text "transform"+pprStmtCat (LastStmt {})      = text "return expression"+pprStmtCat (BodyStmt {})      = text "body"+pprStmtCat (BindStmt {})      = text "binding"+pprStmtCat (LetStmt {})       = text "let"+pprStmtCat (RecStmt {})       = text "rec"+pprStmtCat (ParStmt {})       = text "parallel"+pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"+pprStmtCat (XStmtLR nec)        = noExtCon nec++------------+emptyInvalid :: Validity  -- Payload is the empty document+emptyInvalid = NotValid Outputable.empty++okStmt, okDoStmt, okCompStmt, okParStmt+   :: DynFlags -> HsStmtContext Name+   -> Stmt GhcPs (Located (body GhcPs)) -> Validity+-- Return Nothing if OK, (Just extra) if not ok+-- The "extra" is an SDoc that is appended to a generic error message++okStmt dflags ctxt stmt+  = case ctxt of+      PatGuard {}        -> okPatGuardStmt stmt+      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt+      DoExpr             -> okDoStmt   dflags ctxt stmt+      MDoExpr            -> okDoStmt   dflags ctxt stmt+      ArrowExpr          -> okDoStmt   dflags ctxt stmt+      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt+      ListComp           -> okCompStmt dflags ctxt stmt+      MonadComp          -> okCompStmt dflags ctxt stmt+      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt++-------------+okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity+okPatGuardStmt stmt+  = case stmt of+      BodyStmt {} -> IsValid+      BindStmt {} -> IsValid+      LetStmt {}  -> IsValid+      _           -> emptyInvalid++-------------+okParStmt dflags ctxt stmt+  = case stmt of+      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid+      _                              -> okStmt dflags ctxt stmt++----------------+okDoStmt dflags ctxt stmt+  = case stmt of+       RecStmt {}+         | LangExt.RecursiveDo `xopt` dflags -> IsValid+         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'+         | otherwise         -> NotValid (text "Use RecursiveDo")+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       _           -> emptyInvalid++----------------+okCompStmt dflags _ stmt+  = case stmt of+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       ParStmt {}+         | LangExt.ParallelListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use ParallelListComp")+       TransStmt {}+         | LangExt.TransformListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use TransformListComp")+       RecStmt {}  -> emptyInvalid+       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)+       ApplicativeStmt {} -> emptyInvalid+       XStmtLR nec -> noExtCon nec++---------+checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()+checkTupleSection args+  = do  { tuple_section <- xoptM LangExt.TupleSections+        ; checkErr (all tupArgPresent args || tuple_section) msg }+  where+    msg = text "Illegal tuple section: use TupleSections"++---------+sectionErr :: HsExpr GhcPs -> SDoc+sectionErr expr+  = hang (text "A section must be enclosed in parentheses")+       2 (text "thus:" <+> (parens (ppr expr)))++badIpBinds :: Outputable a => SDoc -> a -> SDoc+badIpBinds what binds+  = hang (text "Implicit-parameter bindings illegal in" <+> what)+         2 (ppr binds)++---------++monadFailOp :: LPat GhcPs+            -> HsStmtContext Name+            -> RnM (SyntaxExpr GhcRn, FreeVars)+monadFailOp pat ctxt+  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)+  -- we should not need to fail.+  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)++  -- For non-monadic contexts (e.g. guard patterns, list+  -- comprehensions, etc.) we should not need to fail.  See Note+  -- [Failing pattern matches in Stmts]+  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)++  | otherwise = getMonadFailOp++{-+Note [Monad fail : Rebindable syntax, overloaded strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Given the code+  foo x = do { Just y <- x; return y }++we expect it to desugar as+  foo x = x >>= \r -> case r of+                        Just y  -> return y+                        Nothing -> fail "Pattern match error"++But with RebindableSyntax and OverloadedStrings, we really want+it to desugar thus:+  foo x = x >>= \r -> case r of+                        Just y  -> return y+                        Nothing -> fail (fromString "Patterm match error")++So, in this case, we synthesize the function+  \x -> fail (fromString x)++(rather than plain 'fail') for the 'fail' operation. This is done in+'getMonadFailOp'.+-}+getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op+getMonadFailOp+ = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags+      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings+      }+  where+    reallyGetMonadFailOp rebindableSyntax overloadedStrings+      | rebindableSyntax && overloadedStrings = do+        (failExpr, failFvs) <- lookupSyntaxName failMName+        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName+        let arg_lit = mkVarOcc "arg"+        arg_name <- newSysName arg_lit+        let arg_syn_expr = mkRnSyntaxExpr arg_name+            body :: LHsExpr GhcRn =+              nlHsApp (noLoc $ syn_expr failExpr)+                      (nlHsApp (noLoc $ syn_expr fromStringExpr)+                                (noLoc $ syn_expr arg_syn_expr))+        let failAfterFromStringExpr :: HsExpr GhcRn =+              unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body+        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =+              mkSyntaxExpr failAfterFromStringExpr+        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)+      | otherwise = lookupSyntaxName failMName
+ compiler/GHC/Rename/Expr.hs-boot view
@@ -0,0 +1,17 @@+module GHC.Rename.Expr where+import Name+import GHC.Hs+import NameSet     ( FreeVars )+import TcRnTypes+import SrcLoc      ( Located )+import Outputable  ( Outputable )++rnLExpr :: LHsExpr GhcPs+        -> RnM (LHsExpr GhcRn, FreeVars)++rnStmts :: --forall thing body.+           Outputable (body GhcPs) => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> [LStmt GhcPs (Located (body GhcPs))]+        -> ([Name] -> RnM (thing, FreeVars))+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
+ compiler/GHC/Rename/Fixity.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE ViewPatterns #-}++{-++This module contains code which maintains and manipulates the+fixity environment during renaming.++-}+module GHC.Rename.Fixity+   ( MiniFixityEnv+   , addLocalFixities+   , lookupFixityRn+   , lookupFixityRn_help+   , lookupFieldFixityRn+   , lookupTyFixityRn+   )+where++import GhcPrelude++import GHC.Iface.Load+import GHC.Hs+import RdrName+import HscTypes+import TcRnMonad+import Name+import NameEnv+import Module+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,+                          defaultFixity, SourceText(..) )+import SrcLoc+import Outputable+import Maybes+import Data.List+import Data.Function    ( on )+import GHC.Rename.Unbound++{-+*********************************************************+*                                                      *+                Fixities+*                                                      *+*********************************************************++Note [Fixity signature lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A fixity declaration like++    infixr 2 ?++can refer to a value-level operator, e.g.:++    (?) :: String -> String -> String++or a type-level operator, like:++    data (?) a b = A a | B b++so we extend the lookup of the reader name '?' to the TcClsName namespace, as+well as the original namespace.++The extended lookup is also used in other places, like resolution of+deprecation declarations, and lookup of names in GHCi.+-}++--------------------------------+type MiniFixityEnv = FastStringEnv (Located Fixity)+        -- Mini fixity env for the names we're about+        -- to bind, in a single binding group+        --+        -- It is keyed by the *FastString*, not the *OccName*, because+        -- the single fixity decl       infix 3 T+        -- affects both the data constructor T and the type constructor T+        --+        -- We keep the location so that if we find+        -- a duplicate, we can report it sensibly++--------------------------------+-- Used for nested fixity decls to bind names along with their fixities.+-- the fixities are given as a UFM from an OccName's FastString to a fixity decl++addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a+addLocalFixities mini_fix_env names thing_inside+  = extendFixityEnv (mapMaybe find_fixity names) thing_inside+  where+    find_fixity name+      = case lookupFsEnv mini_fix_env (occNameFS occ) of+          Just lfix -> Just (name, FixItem occ (unLoc lfix))+          Nothing   -> Nothing+      where+        occ = nameOccName name++{-+--------------------------------+lookupFixity is a bit strange.++* Nested local fixity decls are put in the local fixity env, which we+  find with getFixtyEnv++* Imported fixities are found in the PIT++* Top-level fixity decls in this module may be for Names that are+    either  Global         (constructors, class operations)+    or      Local/Exported (everything else)+  (See notes with GHC.Rename.Names.getLocalDeclBinders for why we have this split.)+  We put them all in the local fixity environment+-}++lookupFixityRn :: Name -> RnM Fixity+lookupFixityRn name = lookupFixityRn' name (nameOccName name)++lookupFixityRn' :: Name -> OccName -> RnM Fixity+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name++-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'+-- in a local environment or from an interface file. Otherwise, it returns+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without+-- user-supplied fixity declarations).+lookupFixityRn_help :: Name+                    -> RnM (Bool, Fixity)+lookupFixityRn_help name =+    lookupFixityRn_help' name (nameOccName name)++lookupFixityRn_help' :: Name+                     -> OccName+                     -> RnM (Bool, Fixity)+lookupFixityRn_help' name occ+  | isUnboundName name+  = return (False, Fixity NoSourceText minPrecedence InfixL)+    -- Minimise errors from ubound names; eg+    --    a>0 `foo` b>0+    -- where 'foo' is not in scope, should not give an error (#7937)++  | otherwise+  = do { local_fix_env <- getFixityEnv+       ; case lookupNameEnv local_fix_env name of {+           Just (FixItem _ fix) -> return (True, fix) ;+           Nothing ->++    do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name+               -- Local (and interactive) names are all in the+               -- fixity env, and don't have entries in the HPT+         then return (False, defaultFixity)+         else lookup_imported } } }+  where+    lookup_imported+      -- For imported names, we have to get their fixities by doing a+      -- loadInterfaceForName, and consulting the Ifaces that comes back+      -- from that, because the interface file for the Name might not+      -- have been loaded yet.  Why not?  Suppose you import module A,+      -- which exports a function 'f', thus;+      --        module CurrentModule where+      --          import A( f )+      --        module A( f ) where+      --          import B( f )+      -- Then B isn't loaded right away (after all, it's possible that+      -- nothing from B will be used).  When we come across a use of+      -- 'f', we need to know its fixity, and it's then, and only+      -- then, that we load B.hi.  That is what's happening here.+      --+      -- loadInterfaceForName will find B.hi even if B is a hidden module,+      -- and that's what we want.+      = do { iface <- loadInterfaceForName doc name+           ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ+           ; let msg = case mb_fix of+                            Nothing ->+                                  text "looking up name" <+> ppr name+                              <+> text "in iface, but found no fixity for it."+                              <+> text "Using default fixity instead."+                            Just f ->+                                  text "looking up name in iface and found:"+                              <+> vcat [ppr name, ppr f]+           ; traceRn "lookupFixityRn_either:" msg+           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }++    doc = text "Checking fixity for" <+> ppr name++---------------+lookupTyFixityRn :: Located Name -> RnM Fixity+lookupTyFixityRn = lookupFixityRn . unLoc++-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field+-- selector.  We use 'lookupFixityRn'' so that we can specify the 'OccName' as+-- the field label, which might be different to the 'OccName' of the selector+-- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are+-- multiple possible selectors with different fixities, generate an error.+lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity+lookupFieldFixityRn (Unambiguous n lrdr)+  = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))+lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)+  where+    get_ambiguous_fixity :: RdrName -> RnM Fixity+    get_ambiguous_fixity rdr_name = do+      traceRn "get_ambiguous_fixity" (ppr rdr_name)+      rdr_env <- getGlobalRdrEnv+      let elts =  lookupGRE_RdrName rdr_name rdr_env++      fixities <- groupBy ((==) `on` snd) . zip elts+                  <$> mapM lookup_gre_fixity elts++      case fixities of+        -- There should always be at least one fixity.+        -- Something's very wrong if there are no fixity candidates, so panic+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"+        [ (_, fix):_ ] -> return fix+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)+                  >> return (Fixity NoSourceText minPrecedence InfixL)++    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)++    ambiguous_fixity_err rn ambigs+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)+             , hang (text "Conflicts: ") 2 . vcat .+               map format_ambig $ concat ambigs ]++    format_ambig (elt, fix) = hang (ppr fix)+                                 2 (pprNameProvenance elt)+lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec
+ compiler/GHC/Rename/Names.hs view
@@ -0,0 +1,1786 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Extracting imported and top-level names in scope+-}++{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Rename.Names (+        rnImports, getLocalNonValBinders, newRecordSelector,+        extendGlobalRdrEnvRn,+        gresFromAvails,+        calculateAvails,+        reportUnusedNames,+        checkConName,+        mkChildEnv,+        findChildren,+        dodgyMsg,+        dodgyMsgInsert,+        findImportUsage,+        getMinimalImports,+        printMinimalImports,+        ImportDeclUsage+    ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import TyCoPpr+import GHC.Hs+import TcEnv+import GHC.Rename.Env+import GHC.Rename.Fixity+import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv )+import GHC.Iface.Load   ( loadSrcInterface )+import TcRnMonad+import PrelNames+import Module+import Name+import NameEnv+import NameSet+import Avail+import FieldLabel+import HscTypes+import RdrName+import RdrHsSyn        ( setRdrNameSpace )+import Outputable+import Maybes+import SrcLoc+import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )+import Util+import FastString+import FastStringEnv+import Id+import Type+import PatSyn+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Either      ( partitionEithers, isRight, rights )+import Data.Map         ( Map )+import qualified Data.Map as Map+import Data.Ord         ( comparing )+import Data.List        ( partition, (\\), find, sortBy )+import qualified Data.Set as S+import System.FilePath  ((</>))++import System.IO++{-+************************************************************************+*                                                                      *+\subsection{rnImports}+*                                                                      *+************************************************************************++Note [Tracking Trust Transitively]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we import a package as well as checking that the direct imports are safe+according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]+we must also check that these rules hold transitively for all dependent modules+and packages. Doing this without caching any trust information would be very+slow as we would need to touch all packages and interface files a module depends+on. To avoid this we make use of the property that if a modules Safe Haskell+mode changes, this triggers a recompilation from that module in the dependcy+graph. So we can just worry mostly about direct imports.++There is one trust property that can change for a package though without+recompilation being triggered: package trust. So we must check that all+packages a module transitively depends on to be trusted are still trusted when+we are compiling this module (as due to recompilation avoidance some modules+below may not be considered trusted any more without recompilation being+triggered).++We handle this by augmenting the existing transitive list of packages a module M+depends on with a bool for each package that says if it must be trusted when the+module M is being checked for trust. This list of trust required packages for a+single import is gathered in the rnImportDecl function and stored in an+ImportAvails data structure. The union of these trust required packages for all+imports is done by the rnImports function using the combine function which calls+the plusImportAvails function that is a union operation for the ImportAvails+type. This gives us in an ImportAvails structure all packages required to be+trusted for the module we are currently compiling. Checking that these packages+are still trusted (and that direct imports are trusted) is done in+HscMain.checkSafeImports.++See the note below, [Trust Own Package] for a corner case in this method and+how its handled.+++Note [Trust Own Package]+~~~~~~~~~~~~~~~~~~~~~~~~+There is a corner case of package trust checking that the usual transitive check+doesn't cover. (For how the usual check operates see the Note [Tracking Trust+Transitively] below). The case is when you import a -XSafe module M and M+imports a -XTrustworthy module N. If N resides in a different package than M,+then the usual check works as M will record a package dependency on N's package+and mark it as required to be trusted. If N resides in the same package as M+though, then importing M should require its own package be trusted due to N+(since M is -XSafe so doesn't create this requirement by itself). The usual+check fails as a module doesn't record a package dependency of its own package.+So instead we now have a bool field in a modules interface file that simply+states if the module requires its own package to be trusted. This field avoids+us having to load all interface files that the module depends on to see if one+is trustworthy.+++Note [Trust Transitive Property]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+So there is an interesting design question in regards to transitive trust+checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch+of modules and packages, some packages it requires to be trusted as its using+-XTrustworthy modules from them. Now if I have a module A that doesn't use safe+haskell at all and simply imports B, should A inherit all the trust+requirements from B? Should A now also require that a package p is trusted since+B required it?++We currently say no but saying yes also makes sense. The difference is, if a+module M that doesn't use Safe Haskell imports a module N that does, should all+the trusted package requirements be dropped since M didn't declare that it cares+about Safe Haskell (so -XSafe is more strongly associated with the module doing+the importing) or should it be done still since the author of the module N that+uses Safe Haskell said they cared (so -XSafe is more strongly associated with+the module that was compiled that used it).++Going with yes is a simpler semantics we think and harder for the user to stuff+up but it does mean that Safe Haskell will affect users who don't care about+Safe Haskell as they might grab a package from Cabal which uses safe haskell (say+network) and that packages imports -XTrustworthy modules from another package+(say bytestring), so requires that package is trusted. The user may now get+compilation errors in code that doesn't do anything with Safe Haskell simply+because they are using the network package. They will have to call 'ghc-pkg+trust network' to get everything working. Due to this invasive nature of going+with yes we have gone with no for now.+-}++-- | Process Import Decls.  See 'rnImportDecl' for a description of what+-- the return types represent.+-- Note: Do the non SOURCE ones first, so that we get a helpful warning+-- for SOURCE ones that are unnecessary+rnImports :: [LImportDecl GhcPs]+          -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+rnImports imports = do+    tcg_env <- getGblEnv+    -- NB: want an identity module here, because it's OK for a signature+    -- module to import from its implementor+    let this_mod = tcg_mod tcg_env+    let (source, ordinary) = partition is_source_import imports+        is_source_import d = ideclSource (unLoc d)+    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary+    stuff2 <- mapAndReportM (rnImportDecl this_mod) source+    -- Safe Haskell: See Note [Tracking Trust Transitively]+    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)+    return (decls, rdr_env, imp_avails, hpc_usage)++  where+    -- See Note [Combining ImportAvails]+    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]+            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+    combine ss =+      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr+            plus+            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)+            ss+      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },+            hpc_usage)++    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)+         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)+      = ( decl:decls,+          gbl_env1 `plusGlobalRdrEnv` gbl_env2,+          imp_avails1' `plusImportAvails` imp_avails2,+          hpc_usage1 || hpc_usage2,+          extendModuleSetList finsts_set new_finsts )+      where+      imp_avails1' = imp_avails1 { imp_finsts = [] }+      new_finsts = imp_finsts imp_avails1++{-+Note [Combining ImportAvails]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+imp_finsts in ImportAvails is a list of family instance modules+transitively depended on by an import. imp_finsts for a currently+compiled module is a union of all the imp_finsts of imports.+Computing the union of two lists of size N is O(N^2) and if we+do it to M imports we end up with O(M*N^2). That can get very+expensive for bigger module hierarchies.++Union can be optimized to O(N log N) if we use a Set.+imp_finsts is converted back and forth between dep_finsts, so+changing a type of imp_finsts means either paying for the conversions+or changing the type of dep_finsts as well.++I've measured that the conversions would cost 20% of allocations on my+test case, so that can be ruled out.++Changing the type of dep_finsts forces checkFamInsts to+get the module lists in non-deterministic order. If we wanted to restore+the deterministic order, we'd have to sort there, which is an additional+cost. As far as I can tell, using a non-deterministic order is fine there,+but that's a brittle nonlocal property which I'd like to avoid.++Additionally, dep_finsts is read from an interface file, so its "natural"+type is a list. Which makes it a natural type for imp_finsts.++Since rnImports.combine is really the only place that would benefit from+it being a Set, it makes sense to optimize the hot loop in rnImports.combine+without changing the representation.++So here's what we do: instead of naively merging ImportAvails with+plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts+and compute the union on the side using Sets. When we're done, we can+convert it back to a list. One nice side effect of this approach is that+if there's a lot of overlap in the imp_finsts of imports, the+Set doesn't really need to grow and we don't need to allocate.++Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in+23s before, and 11s after.+-}++++-- | Given a located import declaration @decl@ from @this_mod@,+-- calculate the following pieces of information:+--+--  1. An updated 'LImportDecl', where all unresolved 'RdrName' in+--     the entity lists have been resolved into 'Name's,+--+--  2. A 'GlobalRdrEnv' representing the new identifiers that were+--     brought into scope (taking into account module qualification+--     and hiding),+--+--  3. 'ImportAvails' summarizing the identifiers that were imported+--     by this declaration, and+--+--  4. A boolean 'AnyHpcUsage' which is true if the imported module+--     used HPC.+rnImportDecl  :: Module -> LImportDecl GhcPs+             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)+rnImportDecl this_mod+             (L loc decl@(ImportDecl { ideclExt = noExtField+                                     , ideclName = loc_imp_mod_name+                                     , ideclPkgQual = mb_pkg+                                     , ideclSource = want_boot, ideclSafe = mod_safe+                                     , ideclQualified = qual_style, ideclImplicit = implicit+                                     , ideclAs = as_mod, ideclHiding = imp_details }))+  = setSrcSpan loc $ do++    when (isJust mb_pkg) $ do+        pkg_imports <- xoptM LangExt.PackageImports+        when (not pkg_imports) $ addErr packageImportErr++    let qual_only = isImportDeclQualified qual_style++    -- If there's an error in loadInterface, (e.g. interface+    -- file not found) we get lots of spurious errors from 'filterImports'+    let imp_mod_name = unLoc loc_imp_mod_name+        doc = ppr imp_mod_name <+> text "is directly imported"++    -- Check for self-import, which confuses the typechecker (#9032)+    -- ghc --make rejects self-import cycles already, but batch-mode may not+    -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid+    -- typechecker crashes.  (Indirect self imports are not caught until+    -- GHC.IfaceToCore, see #10337 tracking how to make this error better.)+    --+    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this+    -- caused bug #10182: in one-shot mode, we should never load an hs-boot+    -- file for the module we are compiling into the EPS.  In principle,+    -- it should be possible to support this mode of use, but we would have to+    -- extend Provenance to support a local definition in a qualified location.+    -- For now, we don't support it, but see #10336+    when (imp_mod_name == moduleName this_mod &&+          (case mb_pkg of  -- If we have import "<pkg>" M, then we should+                           -- check that "<pkg>" is "this" (which is magic)+                           -- or the name of this_mod's package.  Yurgh!+                           -- c.f. GHC.findModule, and #9997+             Nothing         -> True+             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||+                            fsToUnitId pkg_fs == moduleUnitId this_mod))+         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))++    -- Check for a missing import list (Opt_WarnMissingImportList also+    -- checks for T(..) items but that is done in checkDodgyImport below)+    case imp_details of+        Just (False, _) -> return () -- Explicit import list+        _  | implicit   -> return () -- Do not bleat for implicit imports+           | qual_only  -> return ()+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $+                           addWarn (Reason Opt_WarnMissingImportList)+                                   (missingImportListWarn imp_mod_name)++    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)++    -- Compiler sanity check: if the import didn't say+    -- {-# SOURCE #-} we should not get a hi-boot file+    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do++    -- Issue a user warning for a redundant {- SOURCE -} import+    -- NB that we arrange to read all the ordinary imports before+    -- any of the {- SOURCE -} imports.+    --+    -- in --make and GHCi, the compilation manager checks for this,+    -- and indeed we shouldn't do it here because the existence of+    -- the non-boot module depends on the compilation order, which+    -- is not deterministic.  The hs-boot test can show this up.+    dflags <- getDynFlags+    warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))+           (warnRedundantSourceImport imp_mod_name)+    when (mod_safe && not (safeImportsOn dflags)) $+        addErr (text "safe import can't be used as Safe Haskell isn't on!"+                $+$ ptext (sLit $ "please enable Safe Haskell through either "+                                   ++ "Safe, Trustworthy or Unsafe"))++    let+        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name+        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,+                                  is_dloc = loc, is_as = qual_mod_name }++    -- filter the imports according to the import declaration+    (new_imp_details, gres) <- filterImports iface imp_spec imp_details++    -- for certain error messages, we’d like to know what could be imported+    -- here, if everything were imported+    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing++    let gbl_env = mkGlobalRdrEnv gres++        is_hiding | Just (True,_) <- imp_details = True+                  | otherwise                    = False++        -- should the import be safe?+        mod_safe' = mod_safe+                    || (not implicit && safeDirectImpsReq dflags)+                    || (implicit && safeImplicitImpsReq dflags)++    let imv = ImportedModsVal+            { imv_name        = qual_mod_name+            , imv_span        = loc+            , imv_is_safe     = mod_safe'+            , imv_is_hiding   = is_hiding+            , imv_all_exports = potential_gres+            , imv_qualified   = qual_only+            }+        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)++    -- Complain if we import a deprecated module+    whenWOptM Opt_WarnWarningsDeprecations (+       case (mi_warns iface) of+          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)+                                (moduleWarn imp_mod_name txt)+          _           -> return ()+     )++    let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'+                                   , ideclHiding = new_imp_details })++    return (new_imp_decl, gbl_env, imports, mi_hpc iface)+rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec++-- | Calculate the 'ImportAvails' induced by an import of a particular+-- interface, but without 'imp_mods'.+calculateAvails :: DynFlags+                -> ModIface+                -> IsSafeImport+                -> IsBootInterface+                -> ImportedBy+                -> ImportAvails+calculateAvails dflags iface mod_safe' want_boot imported_by =+  let imp_mod    = mi_module iface+      imp_sem_mod= mi_semantic_module iface+      orph_iface = mi_orphan (mi_final_exts iface)+      has_finsts = mi_finsts (mi_final_exts iface)+      deps       = mi_deps iface+      trust      = getSafeMode $ mi_trust iface+      trust_pkg  = mi_trust_pkg iface++      -- If the module exports anything defined in this module, just+      -- ignore it.  Reason: otherwise it looks as if there are two+      -- local definition sites for the thing, and an error gets+      -- reported.  Easiest thing is just to filter them out up+      -- front. This situation only arises if a module imports+      -- itself, or another module that imported it.  (Necessarily,+      -- this involves a loop.)+      --+      -- We do this *after* filterImports, so that if you say+      --      module A where+      --         import B( AType )+      --         type AType = ...+      --+      --      module B( AType ) where+      --         import {-# SOURCE #-} A( AType )+      --+      -- then you won't get a 'B does not export AType' message.+++      -- Compute new transitive dependencies+      --+      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module+      -- itself, but we DO need to include this module in 'imp_orphs' and+      -- 'imp_finsts' if it defines an orphan or instance family; thus the+      -- orph_iface/has_iface tests.++      orphans | orph_iface = ASSERT2( 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++      finsts | has_finsts = ASSERT2( 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++      pkg = moduleUnitId (mi_module iface)+      ipkg = toInstalledUnitId pkg++      -- Does this import mean we now require our own pkg+      -- to be trusted? See Note [Trust Own Package]+      ptrust = trust == Sf_Trustworthy || trust_pkg++      (dependent_mods, dependent_pkgs, pkg_trust_req)+         | pkg == thisPackage dflags =+            -- Imported module is from the home package+            -- Take its dependent modules and add imp_mod itself+            -- Take its dependent packages unchanged+            --+            -- NB: (dep_mods deps) might include a hi-boot file+            -- for the module being compiled, CM. Do *not* filter+            -- this out (as we used to), because when we've+            -- finished dealing with the direct imports we want to+            -- know if any of them depended on CM.hi-boot, in+            -- which case we should do the hi-boot consistency+            -- check.  See GHC.Iface.Load.loadHiBootInterface+            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)++         | otherwise =+            -- Imported module is from another package+            -- Dump the dependent modules+            -- Add the package imp_mod comes from to the dependent packages+            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))+                   , ppr ipkg <+> ppr (dep_pkgs deps) )+            ([], (ipkg, False) : dep_pkgs deps, False)++  in ImportAvails {+          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],+          imp_orphs      = orphans,+          imp_finsts     = finsts,+          imp_dep_mods   = mkModDeps dependent_mods,+          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,+          -- Add in the imported modules trusted package+          -- requirements. ONLY do this though if we import the+          -- module as a safe import.+          -- See Note [Tracking Trust Transitively]+          -- and Note [Trust Transitive Property]+          imp_trust_pkgs = if mod_safe'+                               then S.fromList . map fst $ filter snd dependent_pkgs+                               else S.empty,+          -- Do we require our own pkg to be trusted?+          -- See Note [Trust Own Package]+          imp_trust_own_pkg = pkg_trust_req+     }+++warnRedundantSourceImport :: ModuleName -> SDoc+warnRedundantSourceImport mod_name+  = text "Unnecessary {-# SOURCE #-} in the import of module"+          <+> quotes (ppr mod_name)++{-+************************************************************************+*                                                                      *+\subsection{importsFromLocalDecls}+*                                                                      *+************************************************************************++From the top-level declarations of this module produce+        * the lexical environment+        * the ImportAvails+created by its bindings.++Note [Top-level Names in Template Haskell decl quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also: Note [Interactively-bound Ids in GHCi] in HscTypes+          Note [Looking up Exact RdrNames] in GHC.Rename.Env++Consider a Template Haskell declaration quotation like this:+      module M where+        f x = h [d| f = 3 |]+When renaming the declarations inside [d| ...|], we treat the+top level binders specially in two ways++1.  We give them an Internal Name, not (as usual) an External one.+    This is done by GHC.Rename.Env.newTopSrcBinder.++2.  We make them *shadow* the outer bindings.+    See Note [GlobalRdrEnv shadowing]++3. We find out whether we are inside a [d| ... |] by testing the TH+   stage. This is a slight hack, because the stage field was really+   meant for the type checker, and here we are not interested in the+   fields of Brack, hence the error thunks in thRnBrack.+-}++extendGlobalRdrEnvRn :: [AvailInfo]+                     -> MiniFixityEnv+                     -> RnM (TcGblEnv, TcLclEnv)+-- Updates both the GlobalRdrEnv and the FixityEnv+-- We return a new TcLclEnv only because we might have to+-- delete some bindings from it;+-- see Note [Top-level Names in Template Haskell decl quotes]++extendGlobalRdrEnvRn avails new_fixities+  = do  { (gbl_env, lcl_env) <- getEnvs+        ; stage <- getStage+        ; isGHCi <- getIsGHCi+        ; let rdr_env  = tcg_rdr_env gbl_env+              fix_env  = tcg_fix_env gbl_env+              th_bndrs = tcl_th_bndrs lcl_env+              th_lvl   = thLevel stage++              -- Delete new_occs from global and local envs+              -- If we are in a TemplateHaskell decl bracket,+              --    we are going to shadow them+              -- See Note [GlobalRdrEnv shadowing]+              inBracket = isBrackStage stage++              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }+                           -- See Note [GlobalRdrEnv shadowing]++              lcl_env2 | inBracket = lcl_env_TH+                       | otherwise = lcl_env++              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]+              want_shadowing = isGHCi || inBracket+              rdr_env1 | want_shadowing = shadowNames rdr_env new_names+                       | otherwise      = rdr_env++              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs+                                                       [ (n, (TopLevel, th_lvl))+                                                       | n <- new_names ] }++        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres++        ; let fix_env' = foldl' extend_fix_env fix_env new_gres+              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }++        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)+        ; return (gbl_env', lcl_env3) }+  where+    new_names = concatMap availNames avails+    new_occs  = map nameOccName new_names++    -- If there is a fixity decl for the gre, add it to the fixity env+    extend_fix_env fix_env gre+      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)+      = extendNameEnv fix_env name (FixItem occ fi)+      | otherwise+      = fix_env+      where+        name = gre_name gre+        occ  = greOccName gre++    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails+    new_gres = concatMap localGREsFromAvail avails++    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv+    -- Extend the GlobalRdrEnv with a LocalDef GRE+    -- If there is already a LocalDef GRE with the same OccName,+    --    report an error and discard the new GRE+    -- This establishes INVARIANT 1 of GlobalRdrEnvs+    add_gre env gre+      | not (null dups)    -- Same OccName defined twice+      = do { addDupDeclErr (gre : dups); return env }++      | otherwise+      = return (extendGlobalRdrEnv env gre)+      where+        name = gre_name gre+        occ  = nameOccName name+        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)+++{- *********************************************************************+*                                                                      *+    getLocalDeclBindersd@ returns the names for an HsDecl+             It's used for source code.++        *** See Note [The Naming story] in GHC.Hs.Decls ****+*                                                                      *+********************************************************************* -}++getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs+    -> RnM ((TcGblEnv, TcLclEnv), NameSet)+-- Get all the top-level binders bound the group *except*+-- for value bindings, which are treated separately+-- Specifically we return AvailInfo for+--      * type decls (incl constructors and record selectors)+--      * class decls (including class ops)+--      * associated types+--      * foreign imports+--      * value signatures (in hs-boot files only)++getLocalNonValBinders fixity_env+     (HsGroup { hs_valds  = binds,+                hs_tyclds = tycl_decls,+                hs_fords  = foreign_decls })+  = do  { -- Process all type/class decls *except* family instances+        ; let inst_decls = tycl_decls >>= group_instds+        ; overload_ok <- xoptM LangExt.DuplicateRecordFields+        ; (tc_avails, tc_fldss)+            <- fmap unzip $ mapM (new_tc overload_ok)+                                 (tyClGroupTyClDecls tycl_decls)+        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)+        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env+        ; setEnvs envs $ do {+            -- Bring these things into scope first+            -- See Note [Looking up family names in family instances]++          -- Process all family instances+          -- to bring new data constructors into scope+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)+                                                   inst_decls++          -- Finish off with value binders:+          --    foreign decls and pattern synonyms for an ordinary module+          --    type sigs in case of a hs-boot file only+        ; is_boot <- tcIsHsBootOrSig+        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs+                        | otherwise = for_hs_bndrs+        ; val_avails <- mapM new_simple val_bndrs++        ; let avails    = concat nti_availss ++ val_avails+              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`+                          availsToNameSetWithSelectors tc_avails+              flds      = concat nti_fldss ++ concat tc_fldss+        ; traceRn "getLocalNonValBinders 2" (ppr avails)+        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env++        -- Extend tcg_field_env with new fields (this used to be the+        -- work of extendRecordFieldEnv)+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds+              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)++        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])+        ; return (envs, new_bndrs) } }+  where+    ValBinds _ _val_binds val_sigs = binds++    for_hs_bndrs :: [Located RdrName]+    for_hs_bndrs = hsForeignDeclsBinders foreign_decls++    -- In a hs-boot file, the value binders come from the+    --  *signatures*, and there should be no foreign binders+    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)+                        | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]++      -- the SrcSpan attached to the input should be the span of the+      -- declaration, not just the name+    new_simple :: Located RdrName -> RnM AvailInfo+    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name+                            ; return (avail nm) }++    new_tc :: Bool -> LTyClDecl GhcPs+           -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_tc overload_ok tc_decl -- NOT for type/data instances+        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl+             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; let fld_env = case unLoc tc_decl of+                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'+                     _                            -> []+             ; return (AvailTC main_name names flds', fld_env) }+++    -- Calculate the mapping from constructor names to fields, which+    -- will go in tcg_field_env. It's convenient to do this here where+    -- we are working with a single datatype definition.+    mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]+               -> [(Name, [FieldLabel])]+    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)+      where+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr+                                       , con_args = RecCon cdflds }))+            = [( find_con_name rdr+               , concatMap find_con_decl_flds (unLoc cdflds) )]+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs+                                        , con_args = RecCon flds }))+            = [ ( find_con_name rdr+                 , concatMap find_con_decl_flds (unLoc flds))+              | L _ rdr <- rdrs ]++        find_con_flds _ = []++        find_con_name rdr+          = expectJust "getLocalNonValBinders/find_con_name" $+              find (\ n -> nameOccName n == rdrNameOcc rdr) names+        find_con_decl_flds (L _ x)+          = map find_con_decl_fld (cd_fld_names x)++        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))+          = expectJust "getLocalNonValBinders/find_con_decl_fld" $+              find (\ fl -> flLabel fl == lbl) flds+          where lbl = occNameFS (rdrNameOcc rdr)+        find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec++    new_assoc :: Bool -> LInstDecl GhcPs+              -> RnM ([AvailInfo], [(Name, [FieldLabel])])+    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])+      -- type instances don't bind new names++    new_assoc overload_ok (L _ (DataFamInstD _ d))+      = do { (avail, flds) <- new_di overload_ok Nothing d+           ; return ([avail], flds) }+    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty+                                                      , cid_datafam_insts = adts })))+      = do -- First, attempt to grab the name of the class from the instance.+           -- This step could fail if the instance is not headed by a class,+           -- such as in the following examples:+           --+           -- (1) The class is headed by a bang pattern, such as in+           --     `instance !Show Int` (#3811c)+           -- (2) The class is headed by a type variable, such as in+           --     `instance c` (#16385)+           --+           -- If looking up the class name fails, then mb_cls_nm will+           -- be Nothing.+           mb_cls_nm <- runMaybeT $ do+             -- See (1) above+             L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty+             -- See (2) above+             MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr+           -- Assuming the previous step succeeded, process any associated data+           -- family instances. If the previous step failed, bail out.+           case mb_cls_nm of+             Nothing -> pure ([], [])+             Just cls_nm -> do+               (avails, fldss)+                 <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts+               pure (avails, concat fldss)+    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec+    new_assoc _ (L _ (XInstDecl nec))                 = noExtCon nec++    new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =+                                     HsIB { hsib_body = ti_decl }})+        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)+             ; let (bndrs, flds) = hsDataFamInstBinders dfid+             ; sub_names <- mapM newTopSrcBinder bndrs+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; let avail    = AvailTC (unLoc main_name) sub_names flds'+                                  -- main_name is not bound here!+                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'+             ; return (avail, fld_env) }+    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec++    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d+getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec++newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel+newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"+newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))+  = do { selName <- newTopSrcBinder $ L loc $ field+       ; return $ qualFieldLbl { flSelector = selName } }+  where+    fieldOccName = occNameFS $ rdrNameOcc fld+    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok+    field | isExact fld = fld+              -- use an Exact RdrName as is to preserve the bindings+              -- of an already renamer-resolved field and its use+              -- sites. This is needed to correctly support record+              -- selectors in Template Haskell. See Note [Binders in+              -- Template Haskell] in Convert.hs and Note [Looking up+              -- Exact RdrNames] in GHC.Rename.Env.+          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)++{-+Note [Looking up family names in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  module M where+    type family T a :: *+    type instance M.T Int = Bool++We might think that we can simply use 'lookupOccRn' when processing the type+instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in+the *same* HsGroup as the type instance declaration.  Hence, as we are+currently collecting the binders declared in that HsGroup, these binders will+not have been added to the global environment yet.++Solution is simple: process the type family declarations first, extend+the environment, and then process the type instances.+++************************************************************************+*                                                                      *+\subsection{Filtering imports}+*                                                                      *+************************************************************************++@filterImports@ takes the @ExportEnv@ telling what the imported module makes+available, and filters it through the import spec (if any).++Note [Dealing with imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+For import M( ies ), we take the mi_exports of M, and make+   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)+One entry for each Name that M exports; the AvailInfo is the+AvailInfo exported from M that exports that Name.++The situation is made more complicated by associated types. E.g.+   module M where+     class    C a    where { data T a }+     instance C Int  where { data T Int = T1 | T2 }+     instance C Bool where { data T Int = T3 }+Then M's export_avails are (recall the AvailTC invariant from Avails.hs)+  C(C,T), T(T,T1,T2,T3)+Notice that T appears *twice*, once as a child and once as a parent. From+this list we construct a raw list including+   T -> (T, T( T1, T2, T3 ), Nothing)+   T -> (C, C( C, T ),       Nothing)+and we combine these (in function 'combine' in 'imp_occ_env' in+'filterImports') to get+   T  -> (T,  T(T,T1,T2,T3), Just C)++So the overall imp_occ_env is+   C  -> (C,  C(C,T),        Nothing)+   T  -> (T,  T(T,T1,T2,T3), Just C)+   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3++If we say+   import M( T(T1,T2) )+then we get *two* Avails:  C(T), T(T1,T2)++Note that the imp_occ_env will have entries for data constructors too,+although we never look up data constructors.+-}++filterImports+    :: ModIface+    -> ImpDeclSpec                     -- The span for the entire import decl+    -> Maybe (Bool, Located [LIE GhcPs])    -- Import spec; True => hiding+    -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names+            [GlobalRdrElt])                   -- Same again, but in GRE form+filterImports iface decl_spec Nothing+  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))+  where+    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }+++filterImports iface decl_spec (Just (want_hiding, L l import_items))+  = do  -- check for errors, convert RdrNames to Names+        items1 <- mapM lookup_lie import_items++        let items2 :: [(LIE GhcRn, AvailInfo)]+            items2 = concat items1+                -- NB the AvailInfo may have duplicates, and several items+                --    for the same parent; e.g N(x) and N(y)++            names  = availsToNameSetWithSelectors (map snd items2)+            keep n = not (n `elemNameSet` names)+            pruned_avails = filterAvails keep all_avails+            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }++            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails+                 | otherwise   = concatMap (gresFromIE decl_spec) items2++        return (Just (want_hiding, L l (map fst items2)), gres)+  where+    all_avails = mi_exports iface++        -- See Note [Dealing with imports]+    imp_occ_env :: OccEnv (Name,    -- the name+                           AvailInfo,   -- the export item providing the name+                           Maybe Name)  -- the parent of associated types+    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))+                                     | a <- all_avails+                                     , (n, occ) <- availNamesWithOccs a]+      where+        -- See Note [Dealing with imports]+        -- 'combine' is only called for associated data types which appear+        -- twice in the all_avails. In the example, we combine+        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)+        -- NB: the AvailTC can have fields as well as data constructors (#12127)+        combine (name1, a1@(AvailTC p1 _ _), mp1)+                (name2, a2@(AvailTC p2 _ _), mp2)+          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2+                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )+            if p1 == name1 then (name1, a1, Just p2)+                           else (name1, a2, Just p1)+        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)++    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)+    lookup_name ie rdr+       | isQual rdr              = failLookupWith (QualImportError rdr)+       | Just succ <- mb_success = return succ+       | otherwise               = failLookupWith (BadImport ie)+      where+        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)++    lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]+    lookup_lie (L loc ieRdr)+        = do (stuff, warns) <- setSrcSpan loc $+                               liftM (fromMaybe ([],[])) $+                               run_lookup (lookup_ie ieRdr)+             mapM_ emit_warning warns+             return [ (L loc ie, avail) | (ie,avail) <- stuff ]+        where+            -- Warn when importing T(..) if T was exported abstractly+            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $+              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)+            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $+              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $+              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))++            run_lookup :: IELookupM a -> TcRn (Maybe a)+            run_lookup m = case m of+              Failed err -> addErr (lookup_err_msg err) >> return Nothing+              Succeeded a -> return (Just a)++            lookup_err_msg err = case err of+              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails+              IllegalImport -> illegalImportItemErr+              QualImportError rdr -> qualImportItemErr rdr++        -- For each import item, we convert its RdrNames to Names,+        -- and at the same time construct an AvailInfo corresponding+        -- to what is actually imported by this item.+        -- Returns Nothing on error.+        -- We return a list here, because in the case of an import+        -- item like C, if we are hiding, then C refers to *both* a+        -- type/class and a data constructor.  Moreover, when we import+        -- data constructors of an associated family, we need separate+        -- AvailInfos for the data constructors and the family (as they have+        -- different parents).  See Note [Dealing with imports]+    lookup_ie :: IE GhcPs+              -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])+    lookup_ie ie = handle_bad_import $ do+      case ie of+        IEVar _ (L l n) -> do+            (name, avail, _) <- lookup_name ie $ ieWrappedName n+            return ([(IEVar noExtField (L l (replaceWrappedName n name)),+                                                  trimAvail avail name)], [])++        IEThingAll _ (L l tc) -> do+            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc+            let warns = case avail of+                          Avail {}                     -- e.g. f(..)+                            -> [DodgyImport $ ieWrappedName tc]++                          AvailTC _ subs fs+                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym+                            -> [DodgyImport $ ieWrappedName tc]++                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )+                            -> [MissingImportList]++                            | otherwise+                            -> []++                renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name))+                sub_avails = case avail of+                               Avail {}              -> []+                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]+            case mb_parent of+              Nothing     -> return ([(renamed_ie, avail)], warns)+                             -- non-associated ty/cls+              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)+                             -- associated type++        IEThingAbs _ (L l tc')+            | want_hiding   -- hiding ( C )+                       -- Here the 'C' can be a data constructor+                       --  *or* a type/class, or even both+            -> let tc = ieWrappedName tc'+                   tc_name = lookup_name ie tc+                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)+               in+               case catIELookupM [ tc_name, dc_name ] of+                 []    -> failLookupWith (BadImport ie)+                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])+            | otherwise+            -> do nameAvail <- lookup_name ie (ieWrappedName tc')+                  return ([mkIEThingAbs tc' l nameAvail]+                         , [])++        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->+          ASSERT2(null rdr_fs, ppr rdr_fs) do+           (name, avail, mb_parent)+               <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc)++           let (ns,subflds) = case avail of+                                AvailTC _ ns' subflds' -> (ns',subflds')+                                Avail _                -> panic "filterImports"++           -- Look up the children in the sub-names of the parent+           let subnames = case ns of   -- The tc is first in ns,+                            [] -> []   -- if it is there at all+                                       -- See the AvailTC Invariant in Avail.hs+                            (n1:ns1) | n1 == name -> ns1+                                     | otherwise  -> ns+           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of++             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))+                                -- We are trying to import T( a,b,c,d ), and failed+                                -- to find 'b' and 'd'.  So we make up an import item+                                -- to report as failing, namely T( b, d ).+                                -- c.f. #15412++             Succeeded (childnames, childflds) ->+               case mb_parent of+                 -- non-associated ty/cls+                 Nothing+                   -> return ([(IEThingWith noExtField (L l name') wc childnames'+                                                                 childflds,+                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],+                              [])+                   where name' = replaceWrappedName rdr_tc name+                         childnames' = map to_ie_post_rn childnames+                         -- childnames' = postrn_ies childnames+                 -- associated ty+                 Just parent+                   -> return ([(IEThingWith noExtField (L l name') wc childnames'+                                                           childflds,+                                AvailTC name (map unLoc childnames) (map unLoc childflds)),+                               (IEThingWith noExtField (L l name') wc childnames'+                                                           childflds,+                                AvailTC parent [name] [])],+                              [])+                   where name' = replaceWrappedName rdr_tc name+                         childnames' = map to_ie_post_rn childnames++        _other -> failLookupWith IllegalImport+        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed+        -- all errors.++      where+        mkIEThingAbs tc l (n, av, Nothing    )+          = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n)+        mkIEThingAbs tc l (n, _,  Just parent)+          = (IEThingAbs noExtField (L l (replaceWrappedName tc n))+             , AvailTC parent [n] [])++        handle_bad_import m = catchIELookup m $ \err -> case err of+          BadImport ie | want_hiding -> return ([], [BadImportW ie])+          _                          -> failLookupWith err++type IELookupM = MaybeErr IELookupError++data IELookupWarning+  = BadImportW (IE GhcPs)+  | MissingImportList+  | DodgyImport RdrName+  -- NB. use the RdrName for reporting a "dodgy" import++data IELookupError+  = QualImportError RdrName+  | BadImport (IE GhcPs)+  | IllegalImport++failLookupWith :: IELookupError -> IELookupM a+failLookupWith err = Failed err++catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a+catchIELookup m h = case m of+  Succeeded r -> return r+  Failed err  -> h err++catIELookupM :: [IELookupM a] -> [a]+catIELookupM ms = [ a | Succeeded a <- ms ]++{-+************************************************************************+*                                                                      *+\subsection{Import/Export Utils}+*                                                                      *+************************************************************************+-}++-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.+gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]+gresFromIE decl_spec (L loc ie, avail)+  = gresFromAvail prov_fn avail+  where+    is_explicit = case ie of+                    IEThingAll _ name -> \n -> n == lieWrappedName name+                    _                 -> \_ -> True+    prov_fn name+      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })+      where+        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }+++{-+Note [Children for duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the module++    {-# LANGUAGE DuplicateRecordFields #-}+    module M (F(foo, MkFInt, MkFBool)) where+      data family F a+      data instance F Int = MkFInt { foo :: Int }+      data instance F Bool = MkFBool { foo :: Bool }++The `foo` in the export list refers to *both* selectors! For this+reason, lookupChildren builds an environment that maps the FastString+to a list of items, rather than a single item.+-}++mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]+mkChildEnv gres = foldr add emptyNameEnv gres+  where+    add gre env = case gre_par gre of+        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre+        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre+        NoParent       -> env++findChildren :: NameEnv [a] -> Name -> [a]+findChildren env n = lookupNameEnv env n `orElse` []++lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]+               -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed+                           ([Located Name], [Located FieldLabel])+-- (lookupChildren all_kids rdr_items) maps each rdr_item to its+-- corresponding Name all_kids, if the former exists+-- The matching is done by FastString, not OccName, so that+--    Cls( meth, AssocTy )+-- will correctly find AssocTy among the all_kids of Cls, even though+-- the RdrName for AssocTy may have a (bogus) DataName namespace+-- (Really the rdr_items should be FastStrings in the first place.)+lookupChildren all_kids rdr_items+  | null fails+  = Succeeded (fmap concat (partitionEithers oks))+       -- This 'fmap concat' trickily applies concat to the /second/ component+       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])+  | otherwise+  = Failed fails+  where+    mb_xs = map doOne rdr_items+    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]+    oks   = [ ok      | Succeeded ok   <- mb_xs ]+    oks :: [Either (Located Name) [Located FieldLabel]]++    doOne item@(L l r)+       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of+           Just [Left n]            -> Succeeded (Left (L l n))+           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))+           _                        -> Failed    item++    -- See Note [Children for duplicate record fields]+    kid_env = extendFsEnvList_C (++) emptyFsEnv+              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]++++-------------------------------++{-+*********************************************************+*                                                       *+\subsection{Unused names}+*                                                       *+*********************************************************+-}++reportUnusedNames :: TcGblEnv -> RnM ()+reportUnusedNames gbl_env+  = do  { keep <- readTcRef (tcg_keep gbl_env)+        ; traceRn "RUN" (ppr (tcg_dus gbl_env))+        ; warnUnusedImportDecls gbl_env+        ; warnUnusedTopBinds $ unused_locals keep+        ; warnMissingSignatures gbl_env }+  where+    used_names :: NameSet -> NameSet+    used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep+    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used+    -- Hence findUses++    -- Collect the defined names from the in-scope environment+    defined_names :: [GlobalRdrElt]+    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)++    kids_env = mkChildEnv defined_names+    -- This is done in mkExports too; duplicated work++    gre_is_used :: NameSet -> GlobalRdrElt -> Bool+    gre_is_used used_names (GRE {gre_name = name})+        = name `elemNameSet` used_names+          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)+                -- A use of C implies a use of T,+                -- if C was brought into scope by T(..) or T(C)++    -- Filter out the ones that are+    --  (a) defined in this module, and+    --  (b) not defined by a 'deriving' clause+    -- The latter have an Internal Name, so we can filter them out easily+    unused_locals :: NameSet -> [GlobalRdrElt]+    unused_locals keep =+      let -- Note that defined_and_used, defined_but_not_used+          -- are both [GRE]; that's why we need defined_and_used+          -- rather than just used_names+          _defined_and_used, defined_but_not_used :: [GlobalRdrElt]+          (_defined_and_used, defined_but_not_used)+              = partition (gre_is_used (used_names keep)) defined_names++      in filter is_unused_local defined_but_not_used+    is_unused_local :: GlobalRdrElt -> Bool+    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)++{- *********************************************************************+*                                                                      *+              Missing signatures+*                                                                      *+********************************************************************* -}++-- | Warn the user about top level binders that lack type signatures.+-- Called /after/ type inference, so that we can report the+-- inferred type of the function+warnMissingSignatures :: TcGblEnv -> RnM ()+warnMissingSignatures gbl_env+  = do { let exports = availsToNameSet (tcg_exports gbl_env)+             sig_ns  = tcg_sigs gbl_env+               -- We use sig_ns to exclude top-level bindings that are generated by GHC+             binds    = collectHsBindsBinders $ tcg_binds gbl_env+             pat_syns = tcg_patsyns gbl_env++         -- Warn about missing signatures+         -- Do this only when we have a type to offer+       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures+       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures+       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures++       ; let add_sig_warns+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures+               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures+               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures+               | otherwise          = return ()++             add_warns flag+                = when warn_pat_syns+                       (mapM_ add_pat_syn_warn pat_syns) >>+                  when (warn_missing_sigs || warn_only_exported)+                       (mapM_ add_bind_warn binds)+                where+                  add_pat_syn_warn p+                    = add_warn name $+                      hang (text "Pattern synonym with no type signature:")+                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)+                    where+                      name  = patSynName p+                      pp_ty = pprPatSynType p++                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()+                  add_bind_warn id+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?+                         ; let name    = idName id+                               (_, ty) = tidyOpenType env (idType id)+                               ty_msg  = pprSigmaType ty+                         ; add_warn name $+                           hang (text "Top-level binding with no type signature:")+                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }++                  add_warn name msg+                    = when (name `elemNameSet` sig_ns && export_check name)+                           (addWarnAt (Reason flag) (getSrcSpan name) msg)++                  export_check name+                    = not warn_only_exported || name `elemNameSet` exports++       ; add_sig_warns }+++{-+*********************************************************+*                                                       *+\subsection{Unused imports}+*                                                       *+*********************************************************++This code finds which import declarations are unused.  The+specification and implementation notes are here:+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports++See also Note [Choosing the best import declaration] in RdrName+-}++type ImportDeclUsage+   = ( LImportDecl GhcRn   -- The import declaration+     , [GlobalRdrElt]      -- What *is* used (normalised)+     , [Name] )            -- What is imported but *not* used++warnUnusedImportDecls :: TcGblEnv -> RnM ()+warnUnusedImportDecls gbl_env+  = do { uses <- readMutVar (tcg_used_gres gbl_env)+       ; let user_imports = filterOut+                              (ideclImplicit . unLoc)+                              (tcg_rn_imports gbl_env)+                -- This whole function deals only with *user* imports+                -- both for warning about unnecessary ones, and for+                -- deciding the minimal ones+             rdr_env = tcg_rdr_env gbl_env+             fld_env = mkFieldEnv rdr_env++       ; let usage :: [ImportDeclUsage]+             usage = findImportUsage user_imports uses++       ; traceRn "warnUnusedImportDecls" $+                       (vcat [ text "Uses:" <+> ppr uses+                             , text "Import usage" <+> ppr usage])++       ; whenWOptM Opt_WarnUnusedImports $+         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage++       ; whenGOptM Opt_D_dump_minimal_imports $+         printMinimalImports usage }++findImportUsage :: [LImportDecl GhcRn]+                -> [GlobalRdrElt]+                -> [ImportDeclUsage]++findImportUsage imports used_gres+  = map unused_decl imports+  where+    import_usage :: ImportMap+    import_usage = mkImportMap used_gres++    unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))+      = (decl, used_gres, nameSetElemsStable unused_imps)+      where+        used_gres = Map.lookup (srcSpanEnd loc) import_usage+                               -- srcSpanEnd: see Note [The ImportMap]+                    `orElse` []++        used_names   = mkNameSet (map      gre_name        used_gres)+        used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)++        unused_imps   -- Not trivial; see eg #7454+          = case imps of+              Just (False, L _ imp_ies) ->+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies+              _other -> emptyNameSet -- No explicit import list => no unused-name list++        add_unused :: IE GhcRn -> NameSet -> NameSet+        add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc+        add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc+        add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc+        add_unused (IEThingWith _ p wc ns fs) acc =+          add_wc_all (add_unused_with pn xs acc)+          where pn = lieWrappedName p+                xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs+                add_wc_all = case wc of+                            NoIEWildcard -> id+                            IEWildcard _ -> add_unused_all pn+        add_unused _ acc = acc++        add_unused_name n acc+          | n `elemNameSet` used_names = acc+          | otherwise                  = acc `extendNameSet` n+        add_unused_all n acc+          | n `elemNameSet` used_names   = acc+          | n `elemNameSet` used_parents = acc+          | otherwise                    = acc `extendNameSet` n+        add_unused_with p ns acc+          | all (`elemNameSet` acc1) ns = add_unused_name p acc1+          | otherwise = acc1+          where+            acc1 = foldr add_unused_name acc ns+       -- If you use 'signum' from Num, then the user may well have+       -- imported Num(signum).  We don't want to complain that+       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.+    unused_decl (L _ (XImportDecl nec)) = noExtCon nec+++{- Note [The ImportMap]+~~~~~~~~~~~~~~~~~~~~~~~+The ImportMap is a short-lived intermediate data structure records, for+each import declaration, what stuff brought into scope by that+declaration is actually used in the module.++The SrcLoc is the location of the END of a particular 'import'+declaration.  Why *END*?  Because we don't want to get confused+by the implicit Prelude import. Consider (#7476) the module+    import Foo( foo )+    main = print foo+There is an implicit 'import Prelude(print)', and it gets a SrcSpan+of line 1:1 (just the point, not a span). If we use the *START* of+the SrcSpan to identify the import decl, we'll confuse the implicit+import Prelude with the explicit 'import Foo'.  So we use the END.+It's just a cheap hack; we could equally well use the Span too.++The [GlobalRdrElt] are the things imported from that decl.+-}++type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]+     -- If loc :-> gres, then+     --   'loc' = the end loc of the bestImport of each GRE in 'gres'++mkImportMap :: [GlobalRdrElt] -> ImportMap+-- For each of a list of used GREs, find all the import decls that brought+-- it into scope; choose one of them (bestImport), and record+-- the RdrName in that import decl's entry in the ImportMap+mkImportMap gres+  = foldr add_one Map.empty gres+  where+    add_one gre@(GRE { gre_imp = imp_specs }) imp_map+       = Map.insertWith add decl_loc [gre] imp_map+       where+          best_imp_spec = bestImport imp_specs+          decl_loc      = srcSpanEnd (is_dloc (is_decl best_imp_spec))+                        -- For srcSpanEnd see Note [The ImportMap]+          add _ gres = gre : gres++warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)+                 -> ImportDeclUsage -> RnM ()+warnUnusedImport flag fld_env (L loc decl, used, unused)++  -- Do not warn for 'import M()'+  | Just (False,L _ []) <- ideclHiding decl+  = return ()++  -- Note [Do not warn about Prelude hiding]+  | Just (True, L _ hides) <- ideclHiding decl+  , not (null hides)+  , pRELUDE_NAME == unLoc (ideclName decl)+  = return ()++  -- Nothing used; drop entire declaration+  | null used+  = addWarnAt (Reason flag) loc msg1++  -- Everything imported is used; nop+  | null unused+  = return ()++  -- Some imports are unused+  | otherwise+  = addWarnAt (Reason flag) loc  msg2++  where+    msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant+                , nest 2 (text "except perhaps to import instances from"+                                   <+> quotes pp_mod)+                , text "To import instances alone, use:"+                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]+    msg2 = sep [ pp_herald <+> quotes sort_unused+               , text "from module" <+> quotes pp_mod <+> is_redundant]+    pp_herald  = text "The" <+> pp_qual <+> text "import of"+    pp_qual+      | isImportDeclQualified (ideclQualified decl)= text "qualified"+      | otherwise                                  = Outputable.empty+    pp_mod       = ppr (unLoc (ideclName decl))+    is_redundant = text "is redundant"++    -- In warning message, pretty-print identifiers unqualified unconditionally+    -- to improve the consistent for ambiguous/unambiguous identifiers.+    -- See trac#14881.+    ppr_possible_field n = case lookupNameEnv fld_env n of+                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)+                               Nothing  -> pprNameUnqualified n++    -- Print unused names in a deterministic (lexicographic) order+    sort_unused :: SDoc+    sort_unused = pprWithCommas ppr_possible_field $+                  sortBy (comparing nameOccName) unused++{-+Note [Do not warn about Prelude hiding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not warn about+   import Prelude hiding( x, y )+because even if nothing else from Prelude is used, it may be essential to hide+x,y to avoid name-shadowing warnings.  Example (#9061)+   import Prelude hiding( log )+   f x = log where log = ()++++Note [Printing minimal imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To print the minimal imports we walk over the user-supplied import+decls, and simply trim their import lists.  NB that++  * We do *not* change the 'qualified' or 'as' parts!++  * We do not discard a decl altogether; we might need instances+    from it.  Instead we just trim to an empty import list+-}++getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]+getMinimalImports = mapM mk_minimal+  where+    mk_minimal (L l decl, used_gres, unused)+      | null unused+      , Just (False, _) <- ideclHiding decl+      = return (L l decl)+      | otherwise+      = do { let ImportDecl { ideclName    = L _ mod_name+                            , ideclSource  = is_boot+                            , ideclPkgQual = mb_pkg } = decl+           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)+           ; let used_avails = gresToAvailInfo used_gres+                 lies = map (L l) (concatMap (to_ie iface) used_avails)+           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }+      where+        doc = text "Compute minimal imports for" <+> ppr decl++    to_ie :: ModIface -> AvailInfo -> [IE GhcRn]+    -- The main trick here is that if we're importing all the constructors+    -- we want to say "T(..)", but if we're importing only a subset we want+    -- to say "T(A,B,C)".  So we have to find out what the module exports.+    to_ie _ (Avail n)+       = [IEVar noExtField (to_ie_post_rn $ noLoc n)]+    to_ie _ (AvailTC n [m] [])+       | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)]+    to_ie iface (AvailTC n ns fs)+      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface+                 , x == n+                 , x `elem` xs    -- Note [Partial export]+                 ] of+           [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)]+                | otherwise   ->+                   [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+                                (map noLoc fs)]+                                          -- Note [Overloaded field import]+           _other | all_non_overloaded fs+                           -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns+                                 ++ map flSelector fs+                  | otherwise ->+                      [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+                                (map noLoc fs)]+        where++          fld_lbls = map flLabel fs++          all_used (avail_occs, avail_flds)+              = all (`elem` ns) avail_occs+                    && all (`elem` fld_lbls) (map flLabel avail_flds)++          all_non_overloaded = all (not . flIsOverloaded)++printMinimalImports :: [ImportDeclUsage] -> RnM ()+-- See Note [Printing minimal imports]+printMinimalImports imports_w_usage+  = do { imports' <- getMinimalImports imports_w_usage+       ; this_mod <- getModule+       ; dflags   <- getDynFlags+       ; liftIO $+         do { h <- openFile (mkFilename dflags this_mod) WriteMode+            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }+              -- The neverQualify is important.  We are printing Names+              -- but they are in the context of an 'import' decl, and+              -- we never qualify things inside there+              -- E.g.   import Blag( f, b )+              -- not    import Blag( Blag.f, Blag.g )!+       }+  where+    mkFilename dflags this_mod+      | Just d <- dumpDir dflags = d </> basefn+      | otherwise                = basefn+      where+        basefn = moduleNameString (moduleName this_mod) ++ ".imports"+++to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn_var (L l n)+  | isDataOcc $ occName n = L l (IEPattern (L l n))+  | otherwise             = L l (IEName    (L l n))+++to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn (L l n)+  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))+  | otherwise                   = L l (IEName (L l n))+  where occ = occName n++{-+Note [Partial export]+~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   module A( op ) where+     class C a where+       op :: a -> a++   module B where+   import A+   f = ..op...++Then the minimal import for module B is+   import A( op )+not+   import A( C( op ) )+which we would usually generate if C was exported from B.  Hence+the (x `elem` xs) test when deciding what to generate.+++Note [Overloaded field import]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On the other hand, if we have++    {-# LANGUAGE DuplicateRecordFields #-}+    module A where+      data T = MkT { foo :: Int }++    module B where+      import A+      f = ...foo...++then the minimal import for module B must be+    import A ( T(foo) )+because when DuplicateRecordFields is enabled, field selectors are+not in scope without their enclosing datatype.+++************************************************************************+*                                                                      *+\subsection{Errors}+*                                                                      *+************************************************************************+-}++qualImportItemErr :: RdrName -> SDoc+qualImportItemErr rdr+  = hang (text "Illegal qualified name in import item:")+       2 (ppr rdr)++badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc+badImportItemErrStd iface decl_spec ie+  = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,+         text "does not export", quotes (ppr ie)]+  where+    source_import | mi_boot iface = text "(hi-boot interface)"+                  | otherwise     = Outputable.empty++badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs+                        -> SDoc+badImportItemErrDataCon dataType_occ iface decl_spec ie+  = vcat [ text "In module"+             <+> quotes (ppr (is_mod decl_spec))+             <+> source_import <> colon+         , nest 2 $ quotes datacon+             <+> text "is a data constructor of"+             <+> quotes dataType+         , text "To import it use"+         , nest 2 $ text "import"+             <+> ppr (is_mod decl_spec)+             <> parens_sp (dataType <> parens_sp datacon)+         , text "or"+         , nest 2 $ text "import"+             <+> ppr (is_mod decl_spec)+             <> parens_sp (dataType <> text "(..)")+         ]+  where+    datacon_occ = rdrNameOcc $ ieName ie+    datacon = parenSymOcc datacon_occ (ppr datacon_occ)+    dataType = parenSymOcc dataType_occ (ppr dataType_occ)+    source_import | mi_boot iface = text "(hi-boot interface)"+                  | otherwise     = Outputable.empty+    parens_sp d = parens (space <> d <> space)  -- T( f,g )++badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc+badImportItemErr iface decl_spec ie avails+  = case find checkIfDataCon avails of+      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie+      Nothing  -> badImportItemErrStd iface decl_spec ie+  where+    checkIfDataCon (AvailTC _ ns _) =+      case find (\n -> importedFS == nameOccNameFS n) ns of+        Just n  -> isDataConName n+        Nothing -> False+    checkIfDataCon _ = False+    availOccName = nameOccName . availName+    nameOccNameFS = occNameFS . nameOccName+    importedFS = occNameFS . rdrNameOcc $ ieName ie++illegalImportItemErr :: SDoc+illegalImportItemErr = text "Illegal import item"++dodgyImportWarn :: RdrName -> SDoc+dodgyImportWarn item+  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)++dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc+dodgyMsg kind tc ie+  = sep [ text "The" <+> kind <+> ptext (sLit "item")+                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))+                     <+> quotes (ppr ie)+                <+> text "suggests that",+          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",+          text "but it has none" ]++dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)+dodgyMsgInsert tc = IEThingAll noExtField ii+  where+    ii :: LIEWrappedName (IdP (GhcPass p))+    ii = noLoc (IEName $ noLoc tc)+++addDupDeclErr :: [GlobalRdrElt] -> TcRn ()+addDupDeclErr [] = panic "addDupDeclErr: empty list"+addDupDeclErr gres@(gre : _)+  = addErrAt (getSrcSpan (last sorted_names)) $+    -- Report the error at the later location+    vcat [text "Multiple declarations of" <+>+             quotes (ppr (nameOccName name)),+             -- NB. print the OccName, not the Name, because the+             -- latter might not be in scope in the RdrEnv and so will+             -- be printed qualified.+          text "Declared at:" <+>+                   vcat (map (ppr . nameSrcLoc) sorted_names)]+  where+    name = gre_name gre+    sorted_names = sortWith nameSrcLoc (map gre_name gres)++++missingImportListWarn :: ModuleName -> SDoc+missingImportListWarn mod+  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")++missingImportListItem :: IE GhcPs -> SDoc+missingImportListItem ie+  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")++moduleWarn :: ModuleName -> WarningTxt -> SDoc+moduleWarn mod (WarningTxt _ txt)+  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+moduleWarn mod (DeprecatedTxt _ txt)+  = sep [ text "Module" <+> quotes (ppr mod)+                                <+> text "is deprecated:",+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]++packageImportErr :: SDoc+packageImportErr+  = text "Package-qualified imports are not enabled; use PackageImports"++-- This data decl will parse OK+--      data T = a Int+-- treating "a" as the constructor.+-- It is really hard to make the parser spot this malformation.+-- So the renamer has to check that the constructor is legal+--+-- We can get an operator as the constructor, even in the prefix form:+--      data T = :% Int Int+-- from interface files, which always print in prefix form++checkConName :: RdrName -> TcRn ()+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)++badDataCon :: RdrName -> SDoc+badDataCon name+   = hsep [text "Illegal data constructor name", quotes (ppr name)]
+ compiler/GHC/Rename/Pat.hs view
@@ -0,0 +1,900 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Renaming of patterns++Basically dependency analysis.++Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In+general, all of these functions return a renamed thing, and a set of+free variables.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Rename.Pat (-- main entry points+              rnPat, rnPats, rnBindPat, rnPatAndThen,++              NameMaker, applyNameMaker,     -- a utility for making names:+              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,+                                             --   sometimes we want to make top (qualified) names.+              isTopRecNameMaker,++              rnHsRecFields, HsRecFieldContext(..),+              rnHsRecUpdFields,++              -- CpsRn monad+              CpsRn, liftCps,++              -- Literals+              rnLit, rnOverLit,++             -- Pattern Error messages that are also used elsewhere+             checkTupSize, patSigErr+             ) where++-- ENH: thin imports to only what is necessary for patterns++import GhcPrelude++import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )+import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )++#include "HsVersions.h"++import GHC.Hs+import TcRnMonad+import TcHsSyn             ( hsOverLitName )+import GHC.Rename.Env+import GHC.Rename.Fixity+import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames+                           , warnUnusedMatches, newLocalBndrRn+                           , checkUnusedRecordWildcard+                           , checkDupNames, checkDupAndShadowedNames+                           , checkTupSize , unknownSubordinateErr )+import GHC.Rename.Types+import PrelNames+import Name+import NameSet+import RdrName+import BasicTypes+import Util+import ListSetOps          ( removeDups )+import Outputable+import SrcLoc+import Literal             ( inCharRange )+import TysWiredIn          ( nilDataCon )+import DataCon+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad       ( when, ap, guard )+import qualified Data.List.NonEmpty as NE+import Data.Ratio++{-+*********************************************************+*                                                      *+        The CpsRn Monad+*                                                      *+*********************************************************++Note [CpsRn monad]+~~~~~~~~~~~~~~~~~~+The CpsRn monad uses continuation-passing style to support this+style of programming:++        do { ...+           ; ns <- bindNames rs+           ; ...blah... }++   where rs::[RdrName], ns::[Name]++The idea is that '...blah...'+  a) sees the bindings of ns+  b) returns the free variables it mentions+     so that bindNames can report unused ones++In particular,+    mapM rnPatAndThen [p1, p2, p3]+has a *left-to-right* scoping: it makes the binders in+p1 scope over p2,p3.+-}++newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))+                                            -> RnM (r, FreeVars) }+        deriving (Functor)+        -- See Note [CpsRn monad]++instance Applicative CpsRn where+    pure x = CpsRn (\k -> k x)+    (<*>) = ap++instance Monad CpsRn where+  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))++runCps :: CpsRn a -> RnM (a, FreeVars)+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))++liftCps :: RnM a -> CpsRn a+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)++liftCpsFV :: RnM (a, FreeVars) -> CpsRn a+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing+                                     ; (r,fvs2) <- k v+                                     ; return (r, fvs1 `plusFV` fvs2) })++wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)+-- Set the location, and also wrap it around the value returned+wrapSrcSpanCps fn (L loc a)+  = CpsRn (\k -> setSrcSpan loc $+                 unCpsRn (fn a) $ \v ->+                 k (L loc v))++lookupConCps :: Located RdrName -> CpsRn (Located Name)+lookupConCps con_rdr+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr+                    ; (r, fvs) <- k con_name+                    ; return (r, addOneFV fvs (unLoc con_name)) })+    -- We add the constructor name to the free vars+    -- See Note [Patterns are uses]++{-+Note [Patterns are uses]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  module Foo( f, g ) where+  data T = T1 | T2++  f T1 = True+  f T2 = False++  g _ = T1++Arguably we should report T2 as unused, even though it appears in a+pattern, because it never occurs in a constructed position.  See+#7336.+However, implementing this in the face of pattern synonyms would be+less straightforward, since given two pattern synonyms++  pattern P1 <- P2+  pattern P2 <- ()++we need to observe the dependency between P1 and P2 so that type+checking can be done in the correct order (just like for value+bindings). Dependencies between bindings is analyzed in the renamer,+where we don't know yet whether P2 is a constructor or a pattern+synonym. So for now, we do report conid occurrences in patterns as+uses.++*********************************************************+*                                                      *+        Name makers+*                                                      *+*********************************************************++Externally abstract type of name makers,+which is how you go from a RdrName to a Name+-}++data NameMaker+  = LamMk       -- Lambdas+      Bool      -- True <=> report unused bindings+                --   (even if True, the warning only comes out+                --    if -Wunused-matches is on)++  | LetMk       -- Let bindings, incl top level+                -- Do *not* check for unused bindings+      TopLevelFlag+      MiniFixityEnv++topRecNameMaker :: MiniFixityEnv -> NameMaker+topRecNameMaker fix_env = LetMk TopLevel fix_env++isTopRecNameMaker :: NameMaker -> Bool+isTopRecNameMaker (LetMk TopLevel _) = True+isTopRecNameMaker _ = False++localRecNameMaker :: MiniFixityEnv -> NameMaker+localRecNameMaker fix_env = LetMk NotTopLevel fix_env++matchNameMaker :: HsMatchContext a -> NameMaker+matchNameMaker ctxt = LamMk report_unused+  where+    -- Do not report unused names in interactive contexts+    -- i.e. when you type 'x <- e' at the GHCi prompt+    report_unused = case ctxt of+                      StmtCtxt GhciStmtCtxt -> False+                      -- also, don't warn in pattern quotes, as there+                      -- is no RHS where the variables can be used!+                      ThPatQuote            -> False+                      _                     -> True++rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)++newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)+newPatLName name_maker rdr_name@(L loc _)+  = do { name <- newPatName name_maker rdr_name+       ; return (L loc name) }++newPatName :: NameMaker -> Located RdrName -> CpsRn Name+newPatName (LamMk report_unused) rdr_name+  = CpsRn (\ thing_inside ->+        do { name <- newLocalBndrRn rdr_name+           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)+           ; when report_unused $ warnUnusedMatches [name] fvs+           ; return (res, name `delFV` fvs) })++newPatName (LetMk is_top fix_env) rdr_name+  = CpsRn (\ thing_inside ->+        do { name <- case is_top of+                       NotTopLevel -> newLocalBndrRn rdr_name+                       TopLevel    -> newTopSrcBinder rdr_name+           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here+                                        -- See Note [View pattern usage]+             addLocalFixities fix_env [name] $+             thing_inside name })++    -- Note: the bindLocalNames is somewhat suspicious+    --       because it binds a top-level name as a local name.+    --       however, this binding seems to work, and it only exists for+    --       the duration of the patterns and the continuation;+    --       then the top-level name is added to the global env+    --       before going on to the RHSes (see GHC.Rename.Source).++{-+Note [View pattern usage]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let (r, (r -> x)) = x in ...+Here the pattern binds 'r', and then uses it *only* in the view pattern.+We want to "see" this use, and in let-bindings we collect all uses and+report unused variables at the binding level. So we must use bindLocalNames+here, *not* bindLocalNameFV.  #3943.+++Note [Don't report shadowing for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is one special context where a pattern doesn't introduce any new binders -+pattern synonym declarations. Therefore we don't check to see if pattern+variables shadow existing identifiers as they are never bound to anything+and have no scope.++Without this check, there would be quite a cryptic warning that the `x`+in the RHS of the pattern synonym declaration shadowed the top level `x`.++```+x :: ()+x = ()++pattern P x = Just x+```++See #12615 for some more examples.++*********************************************************+*                                                      *+        External entry points+*                                                      *+*********************************************************++There are various entry points to renaming patterns, depending on+ (1) whether the names created should be top-level names or local names+ (2) whether the scope of the names is entirely given in a continuation+     (e.g., in a case or lambda, but not in a let or at the top-level,+      because of the way mutually recursive bindings are handled)+ (3) whether the a type signature in the pattern can bind+        lexically-scoped type variables (for unpacking existential+        type vars in data constructors)+ (4) whether we do duplicate and unused variable checking+ (5) whether there are fixity declarations associated with the names+     bound by the patterns that need to be brought into scope with them.++ Rather than burdening the clients of this module with all of these choices,+ we export the three points in this design space that we actually need:+-}++-- ----------- Entry point 1: rnPats -------------------+-- Binds local names; the scope of the bindings is entirely in the thing_inside+--   * allows type sigs to bind type vars+--   * local namemaker+--   * unused and duplicate checking+--   * no fixities+rnPats :: HsMatchContext Name -- for error messages+       -> [LPat GhcPs]+       -> ([LPat GhcRn] -> RnM (a, FreeVars))+       -> RnM (a, FreeVars)+rnPats ctxt pats thing_inside+  = do  { envs_before <- getRdrEnvs++          -- (1) rename the patterns, bringing into scope all of the term variables+          -- (2) then do the thing inside.+        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do+        { -- Check for duplicated and shadowed names+          -- Must do this *after* renaming the patterns+          -- See Note [Collect binders only after renaming] in GHC.Hs.Utils+          -- Because we don't bind the vars all at once, we can't+          --    check incrementally for duplicates;+          -- Nor can we check incrementally for shadowing, else we'll+          --    complain *twice* about duplicates e.g. f (x,x) = ...+          --+          -- See note [Don't report shadowing for pattern synonyms]+        ; let bndrs = collectPatsBinders pats'+        ; addErrCtxt doc_pat $+          if isPatSynCtxt ctxt+             then checkDupNames bndrs+             else checkDupAndShadowedNames envs_before bndrs+        ; thing_inside pats' } }+  where+    doc_pat = text "In" <+> pprMatchContext ctxt++rnPat :: HsMatchContext Name -- for error messages+      -> LPat GhcPs+      -> (LPat GhcRn -> RnM (a, FreeVars))+      -> RnM (a, FreeVars)     -- Variables bound by pattern do not+                               -- appear in the result FreeVars+rnPat ctxt pat thing_inside+  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')++applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)+                           ; return n }++-- ----------- Entry point 2: rnBindPat -------------------+-- Binds local names; in a recursive scope that involves other bound vars+--      e.g let { (x, Just y) = e1; ... } in ...+--   * does NOT allows type sig to bind type vars+--   * local namemaker+--   * no unused and duplicate checking+--   * fixities might be coming in+rnBindPat :: NameMaker+          -> LPat GhcPs+          -> RnM (LPat GhcRn, FreeVars)+   -- Returned FreeVars are the free variables of the pattern,+   -- of course excluding variables bound by this pattern++rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)++{-+*********************************************************+*                                                      *+        The main event+*                                                      *+*********************************************************+-}++-- ----------- Entry point 3: rnLPatAndThen -------------------+-- General version: parametrized by how you make new names++rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)+  -- Despite the map, the monad ensures that each pattern binds+  -- variables that may be mentioned in subsequent patterns in the list++--------------------+-- The workhorse+rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat++rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)+rnPatAndThen _  (WildPat _)   = return (WildPat noExtField)+rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat+                                     ; return (ParPat x pat') }+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat+                                     ; return (LazyPat x pat') }+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat+                                     ; return (BangPat x pat') }+rnPatAndThen mk (VarPat x (L l rdr))+    = do { loc <- liftCps getSrcSpanM+         ; name <- newPatName mk (L loc rdr)+         ; return (VarPat x (L l name)) }+     -- we need to bind pattern variables for view pattern expressions+     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)++rnPatAndThen mk (SigPat x pat sig)+  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is+  -- important to rename its type signature _before_ renaming the rest of the+  -- pattern, so that type variables are first bound by the _outermost_ pattern+  -- type signature they occur in. This keeps the type checker happy when+  -- pattern type signatures happen to be nested (#7827)+  --+  -- f ((Just (x :: a) :: Maybe a)+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here+  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here+  = do { sig' <- rnHsSigCps sig+       ; pat' <- rnLPatAndThen mk pat+       ; return (SigPat x pat' sig' ) }++rnPatAndThen mk (LitPat x lit)+  | HsString src s <- lit+  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)+       ; if ovlStr+         then rnPatAndThen mk+                           (mkNPat (noLoc (mkHsIsString src s))+                                      Nothing)+         else normal_lit }+  | otherwise = normal_lit+  where+    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }++rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)+  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit+       ; mb_neg' -- See Note [Negative zero]+           <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName+                                ; return (Just neg, fvs) }+                  positive = return (Nothing, emptyFVs)+              in liftCpsFV $ case (mb_neg , mb_neg') of+                                  (Nothing, Just _ ) -> negative+                                  (Just _ , Nothing) -> negative+                                  (Nothing, Nothing) -> positive+                                  (Just _ , Just _ ) -> positive+       ; eq' <- liftCpsFV $ lookupSyntaxName eqName+       ; return (NPat x (L l lit') mb_neg' eq') }++rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )+  = do { new_name <- newPatName mk rdr+       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]+                                                -- We skip negateName as+                                                -- negative zero doesn't make+                                                -- sense in n + k patterns+       ; minus <- liftCpsFV $ lookupSyntaxName minusName+       ; ge    <- liftCpsFV $ lookupSyntaxName geName+       ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)+                             (L l lit') lit' ge minus) }+                -- The Report says that n+k patterns must be in Integral++rnPatAndThen mk (AsPat x rdr pat)+  = do { new_name <- newPatLName mk rdr+       ; pat' <- rnLPatAndThen mk pat+       ; return (AsPat x new_name pat') }++rnPatAndThen mk p@(ViewPat x expr pat)+  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns+                      ; checkErr vp_flag (badViewPat p) }+         -- Because of the way we're arranging the recursive calls,+         -- this will be in the right context+       ; expr' <- liftCpsFV $ rnLExpr expr+       ; pat' <- rnLPatAndThen mk pat+       -- Note: at this point the PreTcType in ty can only be a placeHolder+       -- ; return (ViewPat expr' pat' ty) }+       ; return (ViewPat x expr' pat') }++rnPatAndThen mk (ConPatIn con stuff)+   -- rnConPatAndThen takes care of reconstructing the pattern+   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.+  = case unLoc con == nameRdrName (dataConName nilDataCon) of+      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists+                    ; if ol_flag then rnPatAndThen mk (ListPat noExtField [])+                                 else rnConPatAndThen mk con stuff}+      False   -> rnConPatAndThen mk con stuff++rnPatAndThen mk (ListPat _ pats)+  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists+       ; pats' <- rnLPatsAndThen mk pats+       ; case opt_OverloadedLists of+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName+                     ; return (ListPat (Just to_list_name) pats')}+          False -> return (ListPat Nothing pats') }++rnPatAndThen mk (TuplePat x pats boxed)+  = do { liftCps $ checkTupSize (length pats)+       ; pats' <- rnLPatsAndThen mk pats+       ; return (TuplePat x pats' boxed) }++rnPatAndThen mk (SumPat x pat alt arity)+  = do { pat <- rnLPatAndThen mk pat+       ; return (SumPat x pat alt arity)+       }++-- If a splice has been run already, just rename the result.+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))+  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat++rnPatAndThen mk (SplicePat _ splice)+  = do { eith <- liftCpsFV $ rnSplicePat splice+       ; case eith of   -- See Note [rnSplicePat] in GHC.Rename.Splice+           Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed+           Right already_renamed -> return already_renamed }++rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)+++--------------------+rnConPatAndThen :: NameMaker+                -> Located RdrName    -- the constructor+                -> HsConPatDetails GhcPs+                -> CpsRn (Pat GhcRn)++rnConPatAndThen mk con (PrefixCon pats)+  = do  { con' <- lookupConCps con+        ; pats' <- rnLPatsAndThen mk pats+        ; return (ConPatIn con' (PrefixCon pats')) }++rnConPatAndThen mk con (InfixCon pat1 pat2)+  = do  { con' <- lookupConCps con+        ; pat1' <- rnLPatAndThen mk pat1+        ; pat2' <- rnLPatAndThen mk pat2+        ; fixity <- liftCps $ lookupFixityRn (unLoc con')+        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }++rnConPatAndThen mk con (RecCon rpats)+  = do  { con' <- lookupConCps con+        ; rpats' <- rnHsRecPatsAndThen mk con' rpats+        ; return (ConPatIn con' (RecCon rpats')) }++checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()+checkUnusedRecordWildcardCps loc dotdot_names =+  CpsRn (\thing -> do+                    (r, fvs) <- thing ()+                    checkUnusedRecordWildcard loc fvs dotdot_names+                    return (r, fvs) )+--------------------+rnHsRecPatsAndThen :: NameMaker+                   -> Located Name      -- Constructor+                   -> HsRecFields GhcPs (LPat GhcPs)+                   -> CpsRn (HsRecFields GhcRn (LPat GhcRn))+rnHsRecPatsAndThen mk (L _ con)+     hs_rec_fields@(HsRecFields { rec_dotdot = dd })+  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat+                                            hs_rec_fields+       ; flds' <- mapM rn_field (flds `zip` [1..])+       ; check_unused_wildcard (implicit_binders flds' <$> dd)+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }+  where+    mkVarPat l n = VarPat noExtField (L l n)+    rn_field (L l fld, n') =+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)+         ; return (L l (fld { hsRecFieldArg = arg' })) }++    loc = maybe noSrcSpan getLoc dd++    -- Get the arguments of the implicit binders+    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats+      where+        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)++    -- Don't warn for let P{..} = ... in ...+    check_unused_wildcard = case mk of+                              LetMk{} -> const (return ())+                              LamMk{} -> checkUnusedRecordWildcardCps loc++        -- Suppress unused-match reporting for fields introduced by ".."+    nested_mk Nothing  mk                    _  = mk+    nested_mk (Just _) mk@(LetMk {})         _  = mk+    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'+      = LamMk (report_unused && (n' <= n))++{-+************************************************************************+*                                                                      *+        Record fields+*                                                                      *+************************************************************************+-}++data HsRecFieldContext+  = HsRecFieldCon Name+  | HsRecFieldPat Name+  | HsRecFieldUpd++rnHsRecFields+    :: forall arg.+       HsRecFieldContext+    -> (SrcSpan -> RdrName -> arg)+         -- When punning, use this to build a new field+    -> HsRecFields GhcPs (Located arg)+    -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)++-- This surprisingly complicated pass+--   a) looks up the field name (possibly using disambiguation)+--   b) fills in puns and dot-dot stuff+-- When we've finished, we've renamed the LHS, but not the RHS,+-- of each x=e binding+--+-- This is used for record construction and pattern-matching, but not updates.++rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })+  = do { pun_ok      <- xoptM LangExt.RecordPuns+       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields+       ; let parent = guard disambig_ok >> mb_con+       ; flds1  <- mapM (rn_fld pun_ok parent) flds+       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds+       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1+       ; let all_flds | null dotdot_flds = flds1+                      | otherwise        = flds1 ++ dotdot_flds+       ; return (all_flds, mkFVs (getFieldIds all_flds)) }+  where+    mb_con = case ctxt of+                HsRecFieldCon con  -> Just con+                HsRecFieldPat con  -> Just con+                _ {- update -}     -> Nothing++    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)+           -> RnM (LHsRecField GhcRn (Located arg))+    rn_fld pun_ok parent (L l+                           (HsRecField+                              { hsRecFieldLbl =+                                  (L loc (FieldOcc _ (L ll lbl)))+                              , hsRecFieldArg = arg+                              , hsRecPun      = pun }))+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl+           ; arg' <- if pun+                     then do { checkErr pun_ok (badPun (L loc lbl))+                               -- Discard any module qualifier (#11662)+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)+                             ; return (L loc (mk_arg loc arg_rdr)) }+                     else return arg+           ; return (L l (HsRecField+                             { hsRecFieldLbl = (L loc (FieldOcc+                                                          sel (L ll lbl)))+                             , hsRecFieldArg = arg'+                             , hsRecPun      = pun })) }+    rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))+      = panic "rnHsRecFields"+++    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat+              -> Maybe Name -- The constructor (Nothing for an+                                --    out of scope constructor)+              -> [LHsRecField GhcRn (Located arg)] -- Explicit fields+              -> RnM ([LHsRecField GhcRn (Located arg)])   -- Field Labels we need to fill in+    rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match+      | not (isUnboundName con) -- This test is because if the constructor+                                -- isn't in scope the constructor lookup will add+                                -- an error but still return an unbound name. We+                                -- don't want that to screw up the dot-dot fill-in stuff.+      = ASSERT( flds `lengthIs` n )+        do { dd_flag <- xoptM LangExt.RecordWildCards+           ; checkErr dd_flag (needFlagDotDot ctxt)+           ; (rdr_env, lcl_env) <- getRdrEnvs+           ; con_fields <- lookupConstructorFields con+           ; when (null con_fields) (addErr (badDotDotCon con))+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)++                   -- For constructor uses (but not patterns)+                   -- the arg should be in scope locally;+                   -- i.e. not top level or imported+                   -- Eg.  data R = R { x,y :: Int }+                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}+                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env++                 (dot_dot_fields, dot_dot_gres)+                        = unzip [ (fl, gre)+                                | fl <- con_fields+                                , let lbl = mkVarOccFS (flLabel fl)+                                , not (lbl `elemOccSet` present_flds)+                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]+                                              -- Check selector is in scope+                                , case ctxt of+                                    HsRecFieldCon {} -> arg_in_scope lbl+                                    _other           -> True ]++           ; addUsedGREs dot_dot_gres+           ; return [ L loc (HsRecField+                        { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))+                        , hsRecFieldArg = L loc (mk_arg loc arg_rdr)+                        , hsRecPun      = False })+                    | fl <- dot_dot_fields+                    , let sel     = flSelector fl+                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }++    rn_dotdot _dotdot _mb_con _flds+      = return []+      -- _dotdot = Nothing => No ".." at all+      -- _mb_con = Nothing => Record update+      -- _mb_con = Just unbound => Out of scope data constructor++    dup_flds :: [NE.NonEmpty RdrName]+        -- Each list represents a RdrName that occurred more than once+        -- (the list contains all occurrences)+        -- Each list in dup_fields is non-empty+    (_, dup_flds) = removeDups compare (getFieldLbls flds)+++-- NB: Consider this:+--      module Foo where { data R = R { fld :: Int } }+--      module Odd where { import Foo; fld x = x { fld = 3 } }+-- Arguably this should work, because the reference to 'fld' is+-- unambiguous because there is only one field id 'fld' in scope.+-- But currently it's rejected.++rnHsRecUpdFields+    :: [LHsRecUpdField GhcPs]+    -> RnM ([LHsRecUpdField GhcRn], FreeVars)+rnHsRecUpdFields flds+  = do { pun_ok        <- xoptM LangExt.RecordPuns+       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds+       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds++       -- Check for an empty record update  e {}+       -- NB: don't complain about e { .. }, because rn_dotdot has done that already+       ; when (null flds) $ addErr emptyUpdateErr++       ; return (flds1, plusFVs fvss) }+  where+    doc = text "constructor field name"++    rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs+           -> RnM (LHsRecUpdField GhcRn, FreeVars)+    rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f+                                               , hsRecFieldArg = arg+                                               , hsRecPun      = pun }))+      = do { let lbl = rdrNameAmbiguousFieldOcc f+           ; sel <- setSrcSpan loc $+                      -- Defer renaming of overloaded fields to the typechecker+                      -- See Note [Disambiguating record fields] in TcExpr+                      if overload_ok+                          then do { mb <- lookupGlobalOccRn_overloaded+                                            overload_ok lbl+                                  ; case mb of+                                      Nothing ->+                                        do { addErr+                                               (unknownSubordinateErr doc lbl)+                                           ; return (Right []) }+                                      Just r  -> return r }+                          else fmap Left $ lookupGlobalOccRn lbl+           ; arg' <- if pun+                     then do { checkErr pun_ok (badPun (L loc lbl))+                               -- Discard any module qualifier (#11662)+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)+                             ; return (L loc (HsVar noExtField (L loc arg_rdr))) }+                     else return arg+           ; (arg'', fvs) <- rnLExpr arg'++           ; let fvs' = case sel of+                          Left sel_name -> fvs `addOneFV` sel_name+                          Right [sel_name] -> fvs `addOneFV` sel_name+                          Right _       -> fvs+                 lbl' = case sel of+                          Left sel_name ->+                                     L loc (Unambiguous sel_name   (L loc lbl))+                          Right [sel_name] ->+                                     L loc (Unambiguous sel_name   (L loc lbl))+                          Right _ -> L loc (Ambiguous   noExtField (L loc lbl))++           ; return (L l (HsRecField { hsRecFieldLbl = lbl'+                                     , hsRecFieldArg = arg''+                                     , hsRecPun      = pun }), fvs') }++    dup_flds :: [NE.NonEmpty RdrName]+        -- Each list represents a RdrName that occurred more than once+        -- (the list contains all occurrences)+        -- Each list in dup_fields is non-empty+    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)++++getFieldIds :: [LHsRecField GhcRn arg] -> [Name]+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds++getFieldLbls :: [LHsRecField id arg] -> [RdrName]+getFieldLbls flds+  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds++getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds++needFlagDotDot :: HsRecFieldContext -> SDoc+needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,+                            text "Use RecordWildCards to permit this"]++badDotDotCon :: Name -> SDoc+badDotDotCon con+  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)+         , nest 2 (text "The constructor has no labelled fields") ]++emptyUpdateErr :: SDoc+emptyUpdateErr = text "Empty record update"++badPun :: Located RdrName -> SDoc+badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),+                   text "Use NamedFieldPuns to permit this"]++dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc+dupFieldErr ctxt dups+  = hsep [text "duplicate field name",+          quotes (ppr (NE.head dups)),+          text "in record", pprRFC ctxt]++pprRFC :: HsRecFieldContext -> SDoc+pprRFC (HsRecFieldCon {}) = text "construction"+pprRFC (HsRecFieldPat {}) = text "pattern"+pprRFC (HsRecFieldUpd {}) = text "update"++{-+************************************************************************+*                                                                      *+\subsubsection{Literals}+*                                                                      *+************************************************************************++When literals occur we have to make sure+that the types and classes they involve+are made available.+-}++rnLit :: HsLit p -> RnM ()+rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)+rnLit _ = return ()++-- Turn a Fractional-looking literal which happens to be an integer into an+-- Integer-looking literal.+generalizeOverLitVal :: OverLitVal -> OverLitVal+generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))+    | denominator val == 1 = HsIntegral (IL { il_text=src+                                            , il_neg=neg+                                            , il_value=numerator val})+generalizeOverLitVal lit = lit++isNegativeZeroOverLit :: HsOverLit t -> Bool+isNegativeZeroOverLit lit+ = case ol_val lit of+        HsIntegral i   -> 0 == il_value i && il_neg i+        HsFractional f -> 0 == fl_value f && fl_neg f+        _              -> False++{-+Note [Negative zero]+~~~~~~~~~~~~~~~~~~~~~~~~~+There were problems with negative zero in conjunction with Negative Literals+extension. Numeric literal value is contained in Integer and Rational types+inside IntegralLit and FractionalLit. These types cannot represent negative+zero value. So we had to add explicit field 'neg' which would hold information+about literal sign. Here in rnOverLit we use it to detect negative zeroes and+in this case return not only literal itself but also negateName so that users+can apply it explicitly. In this case it stays negative zero.  #13211+-}++rnOverLit :: HsOverLit t ->+             RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)+rnOverLit origLit+  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals+        ; let { lit@(OverLit {ol_val=val})+            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}+            | otherwise       = origLit+          }+        ; let std_name = hsOverLitName val+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)+            <- lookupSyntaxName std_name+        ; let rebindable = case from_thing_name of+                                HsVar _ lv -> (unLoc lv) /= std_name+                                _          -> panic "rnOverLit"+        ; let lit' = lit { ol_witness = from_thing_name+                         , ol_ext = rebindable }+        ; if isNegativeZeroOverLit lit'+          then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)+                      <- lookupSyntaxName negateName+                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)+                                  , fvs1 `plusFV` fvs2) }+          else return ((lit', Nothing), fvs1) }++{-+************************************************************************+*                                                                      *+\subsubsection{Errors}+*                                                                      *+************************************************************************+-}++patSigErr :: Outputable a => a -> SDoc+patSigErr ty+  =  (text "Illegal signature in pattern:" <+> ppr ty)+        $$ nest 4 (text "Use ScopedTypeVariables to permit it")++bogusCharError :: Char -> SDoc+bogusCharError c+  = text "character literal out of range: '\\" <> char c  <> char '\''++badViewPat :: Pat GhcPs -> SDoc+badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,+                       text "Use ViewPatterns to enable view patterns"]
+ compiler/GHC/Rename/Source.hs view
@@ -0,0 +1,2413 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Main pass of renamer+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Rename.Source (+        rnSrcDecls, addTcgDUs, findSplice+    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )+import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )++import GHC.Hs+import FieldLabel+import RdrName+import GHC.Rename.Types+import GHC.Rename.Binds+import GHC.Rename.Env+import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames+                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV+                        , checkShadowedRdrNames, warnUnusedTypePatterns+                        , extendTyVarEnvFVRn, newLocalBndrsRn+                        , withHsDocContext )+import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr )+import GHC.Rename.Names+import GHC.Rename.Doc   ( rnHsDoc, rnMbLHsDoc )+import TcAnnotations    ( annCtxt )+import TcRnMonad++import ForeignCall      ( CCallTarget(..) )+import Module+import HscTypes         ( Warnings(..), plusWarns )+import PrelNames        ( applicativeClassName, pureAName, thenAName+                        , monadClassName, returnMName, thenMName+                        , semigroupClassName, sappendName+                        , monoidClassName, mappendName+                        )+import Name+import NameSet+import NameEnv+import Avail+import Outputable+import Bag+import BasicTypes       ( pprRuleName, TypeOrKind(..) )+import FastString+import SrcLoc+import DynFlags+import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )+import HscTypes         ( HscEnv, hsc_dflags )+import ListSetOps       ( findDupsEq, removeDups, equivClasses )+import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)+                        , stronglyConnCompFromEdgedVerticesUniq )+import UniqSet+import OrdList+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Control.Arrow ( first )+import Data.List ( mapAccumL )+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Maybe ( isNothing, fromMaybe, mapMaybe )+import qualified Data.Set as Set ( difference, fromList, toList, null )+import Data.Function ( on )++{- | @rnSourceDecl@ "renames" declarations.+It simultaneously performs dependency analysis and precedence parsing.+It also does the following error checks:++* Checks that tyvars are used properly. This includes checking+  for undefined tyvars, and tyvars in contexts that are ambiguous.+  (Some of this checking has now been moved to module @TcMonoType@,+  since we don't have functional dependency information at this point.)++* Checks that all variable occurrences are defined.++* Checks the @(..)@ etc constraints in the export list.++Brings the binders of the group into scope in the appropriate places;+does NOT assume that anything is in scope already+-}+rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)+-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files+rnSrcDecls group@(HsGroup { hs_valds   = val_decls,+                            hs_splcds  = splice_decls,+                            hs_tyclds  = tycl_decls,+                            hs_derivds = deriv_decls,+                            hs_fixds   = fix_decls,+                            hs_warnds  = warn_decls,+                            hs_annds   = ann_decls,+                            hs_fords   = foreign_decls,+                            hs_defds   = default_decls,+                            hs_ruleds  = rule_decls,+                            hs_docs    = docs })+ = do {+   -- (A) Process the top-level fixity declarations, creating a mapping from+   --     FastStrings to FixItems. Also checks for duplicates.+   --     See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls+   local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ;++   -- (B) Bring top level binders (and their fixities) into scope,+   --     *except* for the value bindings, which get done in step (D)+   --     with collectHsIdBinders. However *do* include+   --+   --        * Class ops, data constructors, and record fields,+   --          because they do not have value declarations.+   --+   --        * For hs-boot files, include the value signatures+   --          Again, they have no value declarations+   --+   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;+++   setEnvs tc_envs $ do {++   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations++   -- (D1) Bring pattern synonyms into scope.+   --      Need to do this before (D2) because rnTopBindsLHS+   --      looks up those pattern synonyms (#9889)++   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {++   -- (D2) Rename the left-hand sides of the value bindings.+   --     This depends on everything from (B) being in scope.+   --     It uses the fixity env from (A) to bind fixities for view patterns.+   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;++   -- Bind the LHSes (and their fixities) in the global rdr environment+   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders+                                                    -- They are already in scope+   traceRn "rnSrcDecls" (ppr id_bndrs) ;+   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;+   setEnvs tc_envs $ do {++   --  Now everything is in scope, as the remaining renaming assumes.++   -- (E) Rename type and class decls+   --     (note that value LHSes need to be in scope for default methods)+   --+   -- You might think that we could build proper def/use information+   -- for type and class declarations, but they can be involved+   -- in mutual recursion across modules, and we only do the SCC+   -- analysis for them in the type checker.+   -- So we content ourselves with gathering uses only; that+   -- means we'll only report a declaration as unused if it isn't+   -- mentioned at all.  Ah well.+   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;++   -- (F) Rename Value declarations right-hand sides+   traceRn "Start rnmono" empty ;+   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;+   is_boot <- tcIsHsBootOrSig ;+   (rn_val_decls, bind_dus) <- if is_boot+    -- For an hs-boot, use tc_bndrs (which collects how we're renamed+    -- signatures), since val_bndr_set is empty (there are no x = ...+    -- bindings in an hs-boot.)+    then rnTopBindsBoot tc_bndrs new_lhs+    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;+   traceRn "finish rnmono" (ppr rn_val_decls) ;++   -- (G) Rename Fixity and deprecations++   -- Rename fixity declarations and error if we try to+   -- fix something from another module (duplicates were checked in (A))+   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;+   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))+                        fix_decls ;++   -- Rename deprec decls;+   -- check for duplicates and ensure that deprecated things are defined locally+   -- at the moment, we don't keep these around past renaming+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;++   -- (H) Rename Everything else++   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $+                                   rnList rnHsRuleDecls rule_decls ;+                           -- Inside RULES, scoped type variables are on+   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;+   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;+   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;+   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;+   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;+      -- Haddock docs; no free vars+   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;++   last_tcg_env <- getGblEnv ;+   -- (I) Compute the results and return+   let {rn_group = HsGroup { hs_ext     = noExtField,+                             hs_valds   = rn_val_decls,+                             hs_splcds  = rn_splice_decls,+                             hs_tyclds  = rn_tycl_decls,+                             hs_derivds = rn_deriv_decls,+                             hs_fixds   = rn_fix_decls,+                             hs_warnds  = [], -- warns are returned in the tcg_env+                                             -- (see below) not in the HsGroup+                             hs_fords  = rn_foreign_decls,+                             hs_annds  = rn_ann_decls,+                             hs_defds  = rn_default_decls,+                             hs_ruleds = rn_rule_decls,+                             hs_docs   = rn_docs } ;++        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;+        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,+                              src_fvs5, src_fvs6, src_fvs7] ;+                -- It is tiresome to gather the binders from type and class decls++        src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ;+                -- Instance decls may have occurrences of things bound in bind_dus+                -- so we must put other_fvs last++        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)+                        in -- we return the deprecs in the env, not in the HsGroup above+                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };+       } ;+   traceRn "finish rnSrc" (ppr rn_group) ;+   traceRn "finish Dus" (ppr src_dus ) ;+   return (final_tcg_env, rn_group)+                    }}}}+rnSrcDecls (XHsGroup nec) = noExtCon nec++addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv+-- This function could be defined lower down in the module hierarchy,+-- but there doesn't seem anywhere very logical to put it.+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }++rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)+rnList f xs = mapFvRn (wrapLocFstM f) xs++{-+*********************************************************+*                                                       *+        HsDoc stuff+*                                                       *+*********************************************************+-}++rnDocDecl :: DocDecl -> RnM DocDecl+rnDocDecl (DocCommentNext doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentNext rn_doc)+rnDocDecl (DocCommentPrev doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentPrev rn_doc)+rnDocDecl (DocCommentNamed str doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentNamed str rn_doc)+rnDocDecl (DocGroup lev doc) = do+  rn_doc <- rnHsDoc doc+  return (DocGroup lev rn_doc)++{-+*********************************************************+*                                                       *+        Source-code deprecations declarations+*                                                       *+*********************************************************++Check that the deprecated names are defined, are defined locally, and+that there are no duplicate deprecations.++It's only imported deprecations, dealt with in RnIfaces, that we+gather them together.+-}++-- checks that the deprecations are defined locally, and that there are no duplicates+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings+rnSrcWarnDecls _ []+  = return NoWarnings++rnSrcWarnDecls bndr_set decls'+  = do { -- check for duplicates+       ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups+                          in addErrAt loc (dupWarnDecl lrdr' rdr))+               warn_rdr_dups+       ; pairs_s <- mapM (addLocM rn_deprec) decls+       ; return (WarnSome ((concat pairs_s))) }+ where+   decls = concatMap (wd_warnings . unLoc) decls'++   sig_ctxt = TopSigCtxt bndr_set++   rn_deprec (Warning _ rdr_names txt)+       -- ensures that the names are defined locally+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)+                                rdr_names+          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }+   rn_deprec (XWarnDecl nec) = noExtCon nec++   what = text "deprecation"++   warn_rdr_dups = findDupRdrNames+                   $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls++findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]+findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))++-- look for duplicates among the OccNames;+-- we check that the names are defined above+-- invt: the lists returned by findDupsEq always have at least two elements++dupWarnDecl :: Located RdrName -> RdrName -> SDoc+-- Located RdrName -> DeprecDecl RdrName -> SDoc+dupWarnDecl d rdr_name+  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),+          text "also at " <+> ppr (getLoc d)]++{-+*********************************************************+*                                                      *+\subsection{Annotation declarations}+*                                                      *+*********************************************************+-}++rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)+rnAnnDecl ann@(HsAnnotation _ s provenance expr)+  = addErrCtxt (annCtxt ann) $+    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance+       ; (expr', expr_fvs) <- setStage (Splice Untyped) $+                              rnLExpr expr+       ; return (HsAnnotation noExtField s provenance' expr',+                 provenance_fvs `plusFV` expr_fvs) }+rnAnnDecl (XAnnDecl nec) = noExtCon nec++rnAnnProvenance :: AnnProvenance RdrName+                -> RnM (AnnProvenance Name, FreeVars)+rnAnnProvenance provenance = do+    provenance' <- traverse lookupTopBndrRn provenance+    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))++{-+*********************************************************+*                                                      *+\subsection{Default declarations}+*                                                      *+*********************************************************+-}++rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)+rnDefaultDecl (DefaultDecl _ tys)+  = do { (tys', fvs) <- rnLHsTypes doc_str tys+       ; return (DefaultDecl noExtField tys', fvs) }+  where+    doc_str = DefaultDeclCtx+rnDefaultDecl (XDefaultDecl nec) = noExtCon nec++{-+*********************************************************+*                                                      *+\subsection{Foreign declarations}+*                                                      *+*********************************************************+-}++rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })+  = do { topEnv :: HscEnv <- getTopEnv+       ; name' <- lookupLocatedTopBndrRn name+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty++        -- Mark any PackageTarget style imports as coming from the current package+       ; let unitId = thisPackage $ hsc_dflags topEnv+             spec'      = patchForeignImport unitId spec++       ; return (ForeignImport { fd_i_ext = noExtField+                               , fd_name = name', fd_sig_ty = ty'+                               , fd_fi = spec' }, fvs) }++rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })+  = do { name' <- lookupLocatedOccRn name+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty+       ; return (ForeignExport { fd_e_ext = noExtField+                               , fd_name = name', fd_sig_ty = ty'+                               , fd_fe = spec }+                , fvs `addOneFV` unLoc name') }+        -- NB: a foreign export is an *occurrence site* for name, so+        --     we add it to the free-variable list.  It might, for example,+        --     be imported from another module++rnHsForeignDecl (XForeignDecl nec) = noExtCon nec++-- | For Windows DLLs we need to know what packages imported symbols are from+--      to generate correct calls. Imported symbols are tagged with the current+--      package, so if they get inlined across a package boundary we'll still+--      know where they're from.+--+patchForeignImport :: UnitId -> ForeignImport -> ForeignImport+patchForeignImport unitId (CImport cconv safety fs spec src)+        = CImport cconv safety fs (patchCImportSpec unitId spec) src++patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec+patchCImportSpec unitId spec+ = case spec of+        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget+        _                       -> spec++patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget+patchCCallTarget unitId callTarget =+  case callTarget of+  StaticTarget src label Nothing isFun+                              -> StaticTarget src label (Just unitId) isFun+  _                           -> callTarget++{-+*********************************************************+*                                                      *+\subsection{Instance declarations}+*                                                      *+*********************************************************+-}++rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })+  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi+       ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }++rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })+  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi+       ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }++rnSrcInstDecl (ClsInstD { cid_inst = cid })+  = do { traceRn "rnSrcIstDecl {" (ppr cid)+       ; (cid', fvs) <- rnClsInstDecl cid+       ; traceRn "rnSrcIstDecl end }" empty+       ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) }++rnSrcInstDecl (XInstDecl nec) = noExtCon nec++-- | Warn about non-canonical typeclass instance declarations+--+-- A "non-canonical" instance definition can occur for instances of a+-- class which redundantly defines an operation its superclass+-- provides as well (c.f. `return`/`pure`). In such cases, a canonical+-- instance is one where the subclass inherits its method+-- implementation from its superclass instance (usually the subclass+-- has a default method implementation to that effect). Consequently,+-- a non-canonical instance occurs when this is not the case.+--+-- See also descriptions of 'checkCanonicalMonadInstances' and+-- 'checkCanonicalMonoidInstances'+checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()+checkCanonicalInstances cls poly_ty mbinds = do+    whenWOptM Opt_WarnNonCanonicalMonadInstances+        checkCanonicalMonadInstances++    whenWOptM Opt_WarnNonCanonicalMonoidInstances+        checkCanonicalMonoidInstances++  where+    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance+    -- declarations. Specifically, the following conditions are verified:+    --+    -- In 'Monad' instances declarations:+    --+    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)+    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)+    --+    -- In 'Applicative' instance declarations:+    --+    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).+    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).+    --+    checkCanonicalMonadInstances+      | cls == applicativeClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name+                          , fun_matches = mg }+                      | name == pureAName, isAliasMG mg == Just returnMName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadInstances "pure" "return"++                      | name == thenAName, isAliasMG mg == Just thenMName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"++                  _ -> return ()++      | cls == monadClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name+                          , fun_matches = mg }+                      | name == returnMName, isAliasMG mg /= Just pureAName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadInstances "return" "pure"++                      | name == thenMName, isAliasMG mg /= Just thenAName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"++                  _ -> return ()++      | otherwise = return ()++    -- | Check whether Monoid(mappend) is defined in terms of+    -- Semigroup((<>)) (and not the other way round). Specifically,+    -- the following conditions are verified:+    --+    -- In 'Monoid' instances declarations:+    --+    --  * If 'mappend' is overridden it must be canonical+    --    (i.e. @mappend = (<>)@)+    --+    -- In 'Semigroup' instance declarations:+    --+    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).+    --+    checkCanonicalMonoidInstances+      | cls == semigroupClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id      = L _ name+                          , fun_matches = mg }+                      | name == sappendName, isAliasMG mg == Just mappendName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"++                  _ -> return ()++      | cls == monoidClassName  = do+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = L _ name+                          , fun_matches = mg }+                      | name == mappendName, isAliasMG mg /= Just sappendName+                      -> addWarnNonCanonicalMethod2NoDefault+                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"++                  _ -> return ()++      | otherwise = return ()++    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"+    -- binding, and return @Just rhsName@ if this is the case+    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name+    isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []+                                             , m_grhss = grhss })])}+        | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss+        , EmptyLocalBinds _ <- unLoc lbinds+        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)+    isAliasMG _ = Nothing++    -- got "lhs = rhs" but expected something different+    addWarnNonCanonicalMethod1 flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text (lhs ++ " = " ++ rhs)) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Move definition from" <+>+                         quotes (text rhs) <+>+                         text "to" <+> quotes (text lhs)+                       ]++    -- expected "lhs = rhs" but got something else+    addWarnNonCanonicalMethod2 flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text lhs) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Either remove definition for" <+>+                         quotes (text lhs) <+> text "or define as" <+>+                         quotes (text (lhs ++ " = " ++ rhs))+                       ]++    -- like above, but method has no default impl+    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text lhs) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Define as" <+>+                         quotes (text (lhs ++ " = " ++ rhs))+                       ]++    -- stolen from TcInstDcls+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+    instDeclCtxt1 hs_inst_ty+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++    inst_decl_ctxt :: SDoc -> SDoc+    inst_decl_ctxt doc = hang (text "in the instance declaration for")+                         2 (quotes doc <> text ".")+++rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds+                           , cid_sigs = uprags, cid_tyfam_insts = ats+                           , cid_overlap_mode = oflag+                           , cid_datafam_insts = adts })+  = do { (inst_ty', inst_fvs)+           <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty+       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'+       ; cls <-+           case hsTyGetAppHead_maybe head_ty' of+             Just (L _ cls) -> pure cls+             Nothing -> do+               -- The instance is malformed. We'd still like+               -- to make *some* progress (rather than failing outright), so+               -- we report an error and continue for as long as we can.+               -- Importantly, this error should be thrown before we reach the+               -- typechecker, lest we encounter different errors that are+               -- hopelessly confusing (such as the one in #16114).+               addErrAt (getLoc (hsSigType inst_ty)) $+                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))+                    2 (vcat [ text "Class instances must be of the form"+                            , nest 2 $ text "context => C ty_1 ... ty_n"+                            , text "where" <+> quotes (char 'C')+                              <+> text "is a class"+                            ])+               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))++          -- Rename the bindings+          -- The typechecker (not the renamer) checks that all+          -- the bindings are for the right class+          -- (Slightly strangely) when scoped type variables are on, the+          -- forall-d tyvars scope over the method bindings too+       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags++       ; checkCanonicalInstances cls inst_ty' mbinds'++       -- Rename the associated types, and type signatures+       -- Both need to have the instance type variables in scope+       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)+       ; ((ats', adts'), more_fvs)+             <- extendTyVarEnvFVRn ktv_names $+                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts+                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }++       ; let all_fvs = meth_fvs `plusFV` more_fvs+                                `plusFV` inst_fvs+       ; return (ClsInstDecl { cid_ext = noExtField+                             , cid_poly_ty = inst_ty', cid_binds = mbinds'+                             , cid_sigs = uprags', cid_tyfam_insts = ats'+                             , cid_overlap_mode = oflag+                             , cid_datafam_insts = adts' },+                 all_fvs) }+             -- We return the renamed associated data type declarations so+             -- that they can be entered into the list of type declarations+             -- for the binding group, but we also keep a copy in the instance.+             -- The latter is needed for well-formedness checks in the type+             -- checker (eg, to ensure that all ATs of the instance actually+             -- receive a declaration).+             -- NB: Even the copies in the instance declaration carry copies of+             --     the instance context after renaming.  This is a bit+             --     strange, but should not matter (and it would be more work+             --     to remove the context).+rnClsInstDecl (XClsInstDecl nec) = noExtCon nec++rnFamInstEqn :: HsDocContext+             -> AssocTyFamInfo+             -> [Located RdrName]    -- Kind variables from the equation's RHS+             -> FamInstEqn GhcPs rhs+             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))+             -> RnM (FamInstEqn GhcRn rhs', FreeVars)+rnFamInstEqn doc atfi rhs_kvars+    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon+                               , feqn_bndrs  = mb_bndrs+                               , feqn_pats   = pats+                               , feqn_fixity = fixity+                               , feqn_rhs    = payload }}) rn_payload+  = do { let mb_cls = case atfi of+                        NonAssocTyFamEqn     -> Nothing+                        AssocTyFamDeflt cls  -> Just cls+                        AssocTyFamInst cls _ -> Just cls+       ; tycon'   <- lookupFamInstName mb_cls tycon+       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats+             -- Use the "...Dups" form because it's needed+             -- below to report unused binder on the LHS++         -- Implicitly bound variables, empty if we have an explicit 'forall' according+         -- to the "forall-or-nothing" rule.+       ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups+                      | otherwise = []+       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars++       ; let bndrs = fromMaybe [] mb_bndrs+             bnd_vars = map hsLTyVarLocName bndrs+             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars+             -- Make sure to filter out the kind variables that were explicitly+             -- bound in the type patterns.+       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars++         -- all names not bound in an explicit forall+       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names++             -- All the free vars of the family patterns+             -- with a sensible binding location+       ; ((bndrs', pats', payload'), fvs)+              <- bindLocalNamesFV all_imp_var_names $+                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)+                                   Nothing bndrs $ \bndrs' ->+                 -- Note: If we pass mb_cls instead of Nothing here,+                 --  bindLHsTyVarBndrs will use class variables for any names+                 --  the user meant to bring in scope here. This is an explicit+                 --  forall, so we want fresh names, not class variables.+                 --  Thus: always pass Nothing+                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats+                    ; (payload', rhs_fvs) <- rn_payload doc payload++                       -- Report unused binders on the LHS+                       -- See Note [Unused type variables in family instances]+                    ; let groups :: [NonEmpty (Located RdrName)]+                          groups = equivClasses cmpLocated $+                                   pat_kity_vars_with_dups+                    ; nms_dups <- mapM (lookupOccRn . unLoc) $+                                     [ tv | (tv :| (_:_)) <- groups ]+                          -- Add to the used variables+                          --  a) any variables that appear *more than once* on the LHS+                          --     e.g.   F a Int a = Bool+                          --  b) for associated instances, the variables+                          --     of the instance decl.  See+                          --     Note [Unused type variables in family instances]+                    ; let nms_used = extendNameSetList rhs_fvs $+                                        inst_tvs ++ nms_dups+                          inst_tvs = case atfi of+                                       NonAssocTyFamEqn          -> []+                                       AssocTyFamDeflt _         -> []+                                       AssocTyFamInst _ inst_tvs -> inst_tvs+                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'+                    ; warnUnusedTypePatterns all_nms nms_used++                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }++       ; let all_fvs  = fvs `addOneFV` unLoc tycon'+            -- type instance => use, hence addOneFV++       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]+                      , hsib_body+                          = FamEqn { feqn_ext    = noExtField+                                   , feqn_tycon  = tycon'+                                   , feqn_bndrs  = bndrs' <$ mb_bndrs+                                   , feqn_pats   = pats'+                                   , feqn_fixity = fixity+                                   , feqn_rhs    = payload' } },+                 all_fvs) }+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec+rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec++rnTyFamInstDecl :: AssocTyFamInfo+                -> TyFamInstDecl GhcPs+                -> RnM (TyFamInstDecl GhcRn, FreeVars)+rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })+  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn+       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }++-- | Tracks whether we are renaming:+--+-- 1. A type family equation that is not associated+--    with a parent type class ('NonAssocTyFamEqn')+--+-- 2. An associated type family default declaration ('AssocTyFamDeflt')+--+-- 3. An associated type family instance declaration ('AssocTyFamInst')+data AssocTyFamInfo+  = NonAssocTyFamEqn+  | AssocTyFamDeflt Name   -- Name of the parent class+  | AssocTyFamInst  Name   -- Name of the parent class+                    [Name] -- Names of the tyvars of the parent instance decl++-- | Tracks whether we are renaming an equation in a closed type family+-- equation ('ClosedTyFam') or not ('NotClosedTyFam').+data ClosedTyFamInfo+  = NotClosedTyFam+  | ClosedTyFam (Located RdrName) Name+                -- The names (RdrName and Name) of the closed type family++rnTyFamInstEqn :: AssocTyFamInfo+               -> ClosedTyFamInfo+               -> TyFamInstEqn GhcPs+               -> RnM (TyFamInstEqn GhcRn, FreeVars)+rnTyFamInstEqn atfi ctf_info+    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon+                                   , feqn_rhs   = rhs }})+  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs+       ; (eqn'@(HsIB { hsib_body =+                       FamEqn { feqn_tycon = L _ tycon' }}), fvs)+           <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn+       ; case ctf_info of+           NotClosedTyFam -> pure ()+           ClosedTyFam fam_rdr_name fam_name ->+             checkTc (fam_name == tycon') $+             withHsDocContext (TyFamilyCtx fam_rdr_name) $+             wrongTyFamName fam_name tycon'+       ; pure (eqn', fvs) }+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec+rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec++rnTyFamDefltDecl :: Name+                 -> TyFamDefltDecl GhcPs+                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)+rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)++rnDataFamInstDecl :: AssocTyFamInfo+                  -> DataFamInstDecl GhcPs+                  -> RnM (DataFamInstDecl GhcRn, FreeVars)+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =+                         FamEqn { feqn_tycon = tycon+                                , feqn_rhs   = rhs }})})+  = do { let rhs_kvs = extractDataDefnKindVars rhs+       ; (eqn', fvs) <-+           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn+       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))+  = noExtCon nec+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec))+  = noExtCon nec++-- Renaming of the associated types in instances.++-- Rename associated type family decl in class+rnATDecls :: Name      -- Class+          -> [LFamilyDecl GhcPs]+          -> RnM ([LFamilyDecl GhcRn], FreeVars)+rnATDecls cls at_decls+  = rnList (rnFamDecl (Just cls)) at_decls++rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames+                  decl GhcPs ->               -- an instance. rnTyFamInstDecl+                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl+              -> Name      -- Class+              -> [Name]+              -> [Located (decl GhcPs)]+              -> RnM ([Located (decl GhcRn)], FreeVars)+-- Used for data and type family defaults in a class decl+-- and the family instance declarations in an instance+--+-- NB: We allow duplicate associated-type decls;+--     See Note [Associated type instances] in TcInstDcls+rnATInstDecls rnFun cls tv_ns at_insts+  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts+    -- See Note [Renaming associated types]++{- Note [Wildcards in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wild cards can be used in type/data family instance declarations to indicate+that the name of a type variable doesn't matter. Each wild card will be+replaced with a new unique type variable. For instance:++    type family F a b :: *+    type instance F Int _ = Int++is the same as++    type family F a b :: *+    type instance F Int b = Int++This is implemented as follows: Unnamed wildcards remain unchanged after+the renamer, and then given fresh meta-variables during typechecking, and+it is handled pretty much the same way as the ones in partial type signatures.+We however don't want to emit hole constraints on wildcards in family+instances, so we turn on PartialTypeSignatures and turn off warning flag to+let typechecker know this.+See related Note [Wildcards in visible kind application] in TcHsType.hs++Note [Unused type variables in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the flag -fwarn-unused-type-patterns is on, the compiler reports+warnings about unused type variables in type-family instances. A+tpye variable is considered used (i.e. cannot be turned into a wildcard)+when++ * it occurs on the RHS of the family instance+   e.g.   type instance F a b = a    -- a is used on the RHS++ * it occurs multiple times in the patterns on the LHS+   e.g.   type instance F a a = Int  -- a appears more than once on LHS++ * it is one of the instance-decl variables, for associated types+   e.g.   instance C (a,b) where+            type T (a,b) = a+   Here the type pattern in the type instance must be the same as that+   for the class instance, so+            type T (a,_) = a+   would be rejected.  So we should not complain about an unused variable b++As usual, the warnings are not reported for type variables with names+beginning with an underscore.++Extra-constraints wild cards are not supported in type/data family+instance declarations.++Relevant tickets: #3699, #10586, #10982 and #11451.++Note [Renaming associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check that the RHS of the decl mentions only type variables that are explicitly+bound on the LHS.  For example, this is not ok+   class C a b where+      type F a x :: *+   instance C (p,q) r where+      type F (p,q) x = (x, r)   -- BAD: mentions 'r'+c.f. #5515++Kind variables, on the other hand, are allowed to be implicitly or explicitly+bound. As examples, this (#9574) is acceptable:+   class Funct f where+      type Codomain f :: *+   instance Funct ('KProxy :: KProxy o) where+      -- o is implicitly bound by the kind signature+      -- of the LHS type pattern ('KProxy)+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)+And this (#14131) is also acceptable:+    data family Nat :: k -> k -> *+    -- k is implicitly bound by an invisible kind pattern+    newtype instance Nat :: (k -> *) -> (k -> *) -> * where+      Nat :: (forall xx. f xx -> g xx) -> Nat f g+We could choose to disallow this, but then associated type families would not+be able to be as expressive as top-level type synonyms. For example, this type+synonym definition is allowed:+    type T = (Nothing :: Maybe a)+So for parity with type synonyms, we also allow:+    type family   T :: Maybe a+    type instance T = (Nothing :: Maybe a)++All this applies only for *instance* declarations.  In *class*+declarations there is no RHS to worry about, and the class variables+can all be in scope (#5862):+    class Category (x :: k -> k -> *) where+      type Ob x :: k -> Constraint+      id :: Ob x a => x a a+      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c+Here 'k' is in scope in the kind signature, just like 'x'.++Although type family equations can bind type variables with explicit foralls,+it need not be the case that all variables that appear on the RHS must be bound+by a forall. For instance, the following is acceptable:++   class C a where+     type T a b+   instance C (Maybe a) where+     type forall b. T (Maybe a) b = Either a b++Even though `a` is not bound by the forall, this is still accepted because `a`+was previously bound by the `instance C (Maybe a)` part. (see #16116).++In each case, the function which detects improperly bound variables on the RHS+is TcValidity.checkValidFamPats.+-}+++{-+*********************************************************+*                                                      *+\subsection{Stand-alone deriving declarations}+*                                                      *+*********************************************************+-}++rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)+rnSrcDerivDecl (DerivDecl _ ty mds overlap)+  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving+       ; unless standalone_deriv_ok (addErr standaloneDerivErr)+       ; (mds', ty', fvs)+           <- rnLDerivStrategy DerivDeclCtx mds $+              rnHsSigWcType BindUnlessForall DerivDeclCtx ty+       ; warnNoDerivStrat mds' loc+       ; return (DerivDecl noExtField ty' mds' overlap, fvs) }+  where+    loc = getLoc $ hsib_body $ hswc_body ty+rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec++standaloneDerivErr :: SDoc+standaloneDerivErr+  = hang (text "Illegal standalone deriving declaration")+       2 (text "Use StandaloneDeriving to enable this extension")++{-+*********************************************************+*                                                      *+\subsection{Rules}+*                                                      *+*********************************************************+-}++rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)+rnHsRuleDecls (HsRules { rds_src = src+                       , rds_rules = rules })+  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules+       ; return (HsRules { rds_ext = noExtField+                         , rds_src = src+                         , rds_rules = rn_rules }, fvs) }+rnHsRuleDecls (XRuleDecls nec) = noExtCon nec++rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)+rnHsRuleDecl (HsRule { rd_name = rule_name+                     , rd_act  = act+                     , rd_tyvs = tyvs+                     , rd_tmvs = tmvs+                     , rd_lhs  = lhs+                     , rd_rhs  = rhs })+  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs+       ; checkDupRdrNames rdr_names_w_loc+       ; checkShadowedRdrNames rdr_names_w_loc+       ; names <- newLocalBndrsRn rdr_names_w_loc+       ; let doc = RuleCtx (snd $ unLoc rule_name)+       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->+    do { (lhs', fv_lhs') <- rnLExpr lhs+       ; (rhs', fv_rhs') <- rnLExpr rhs+       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'+       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'+                        , rd_name = rule_name+                        , rd_act  = act+                        , rd_tyvs = tyvs'+                        , rd_tmvs = tmvs'+                        , rd_lhs  = lhs'+                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }+  where+    get_var (RuleBndrSig _ v _) = v+    get_var (RuleBndr _ v)      = v+    get_var (XRuleBndr nec)     = noExtCon nec+    in_rule = text "in the rule" <+> pprFullRuleName rule_name+rnHsRuleDecl (XRuleDecl nec) = noExtCon nec++bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs+               -> [LRuleBndr GhcPs] -> [Name]+               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))+               -> RnM (a, FreeVars)+bindRuleTmVars doc tyvs vars names thing_inside+  = go vars names $ \ vars' ->+    bindLocalNamesFV names (thing_inside vars')+  where+    go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside+      = go vars ns $ \ vars' ->+        thing_inside (L l (RuleBndr noExtField (L loc n)) : vars')++    go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)+       (n : ns) thing_inside+      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->+        go vars ns $ \ vars' ->+        thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars')++    go [] [] thing_inside = thing_inside []+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)++    bind_free_tvs = case tyvs of Nothing -> AlwaysBind+                                 Just _  -> NeverBind++bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]+               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))+               -> RnM (b, FreeVars)+bindRuleTyVars doc in_doc (Just bndrs) thing_inside+  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing++{-+Note [Rule LHS validity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check the shape of a transformation rule LHS.  Currently we only allow+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the+@forall@'d variables.++We used restrict the form of the 'ei' to prevent you writing rules+with LHSs with a complicated desugaring (and hence unlikely to match);+(e.g. a case expression is not allowed: too elaborate.)++But there are legitimate non-trivial args ei, like sections and+lambdas.  So it seems simmpler not to check at all, and that is why+check_e is commented out.+-}++checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()+checkValidRule rule_name ids lhs' fv_lhs'+  = do  {       -- Check for the form of the LHS+          case (validRuleLhs ids lhs') of+                Nothing  -> return ()+                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)++                -- Check that LHS vars are all bound+        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]+        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }++validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)+-- Nothing => OK+-- Just e  => Not ok, and e is the offending sub-expression+validRuleLhs foralls lhs+  = checkl lhs+  where+    checkl = check . unLoc++    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1+                                                      `mplus` checkl_e e2+    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2+    check (HsAppType _ e _)               = checkl e+    check (HsVar _ lv)+      | (unLoc lv) `notElem` foralls      = Nothing+    check other                           = Just other  -- Failure++        -- Check an argument+    checkl_e _ = Nothing+    -- Was (check_e e); see Note [Rule LHS validity checking]++{-      Commented out; see Note [Rule LHS validity checking] above+    check_e (HsVar v)     = Nothing+    check_e (HsPar e)     = checkl_e e+    check_e (HsLit e)     = Nothing+    check_e (HsOverLit e) = Nothing++    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2+    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2+    check_e (NegApp e _)         = checkl_e e+    check_e (ExplicitList _ es)  = checkl_es es+    check_e other                = Just other   -- Fails++    checkl_es es = foldr (mplus . checkl_e) Nothing es+-}++badRuleVar :: FastString -> Name -> SDoc+badRuleVar name var+  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+         text "Forall'd variable" <+> quotes (ppr var) <+>+                text "does not appear on left hand side"]++badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc+badRuleLhsErr name lhs bad_e+  = sep [text "Rule" <+> pprRuleName name <> colon,+         nest 2 (vcat [err,+                       text "in left-hand side:" <+> ppr lhs])]+    $$+    text "LHS must be of form (f e1 .. en) where f is not forall'd"+  where+    err = case bad_e of+            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv)+            _                 -> text "Illegal expression:" <+> ppr bad_e++{- **************************************************************+         *                                                      *+      Renaming type, class, instance and role declarations+*                                                               *+*****************************************************************++@rnTyDecl@ uses the `global name function' to create a new type+declaration in which local names have been replaced by their original+names, reporting any unknown names.++Renaming type variables is a pain. Because they now contain uniques,+it is necessary to pass in an association list which maps a parsed+tyvar to its @Name@ representation.+In some cases (type signatures of values),+it is even necessary to go over the type first+in order to get the set of tyvars used by it, make an assoc list,+and then go over it again to rename the tyvars!+However, we can also do some scoping checks at the same time.++Note [Dependency analysis of type, class, and instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A TyClGroup represents a strongly connected components of+type/class/instance decls, together with the role annotations for the+type/class declarations.  The renamer uses strongly connected+comoponent analysis to build these groups.  We do this for a number of+reasons:++* Improve kind error messages. Consider++     data T f a = MkT f a+     data S f a = MkS f (T f a)++  This has a kind error, but the error message is better if you+  check T first, (fixing its kind) and *then* S.  If you do kind+  inference together, you might get an error reported in S, which+  is jolly confusing.  See #4875+++* Increase kind polymorphism.  See TcTyClsDecls+  Note [Grouping of type and class declarations]++Why do the instance declarations participate?  At least two reasons++* Consider (#11348)++     type family F a+     type instance F Int = Bool++     data R = MkR (F Int)++     type Foo = 'MkR 'True++  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't+  know that unless we've looked at the type instance declaration for F+  before kind-checking Foo.++* Another example is this (#3990).++     data family Complex a+     data instance Complex Double = CD {-# UNPACK #-} !Double+                                       {-# UNPACK #-} !Double++     data T = T {-# UNPACK #-} !(Complex Double)++  Here, to generate the right kind of unpacked implementation for T,+  we must have access to the 'data instance' declaration.++* Things become more complicated when we introduce transitive+  dependencies through imported definitions, like in this scenario:++      A.hs+        type family Closed (t :: Type) :: Type where+          Closed t = Open t++        type family Open (t :: Type) :: Type++      B.hs+        data Q where+          Q :: Closed Bool -> Q++        type instance Open Int = Bool++        type S = 'Q 'True++  Somehow, we must ensure that the instance Open Int = Bool is checked before+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,+  we have no idea that Closed depends upon Open!++  To accommodate for these situations, we ensure that an instance is checked+  before every @TyClDecl@ on which it does not depend. That's to say, instances+  are checked as early as possible in @tcTyAndClassDecls@.++------------------------------------+So much for WHY.  What about HOW?  It's pretty easy:++(1) Rename the type/class, instance, and role declarations+    individually++(2) Do strongly-connected component analysis of the type/class decls,+    We'll make a TyClGroup for each SCC++    In this step we treat a reference to a (promoted) data constructor+    K as a dependency on its parent type.  Thus+        data T = K1 | K2+        data S = MkS (Proxy 'K1)+    Here S depends on 'K1 and hence on its parent T.++    In this step we ignore instances; see+    Note [No dependencies on data instances]++(3) Attach roles to the appropriate SCC++(4) Attach instances to the appropriate SCC.+    We add an instance decl to SCC when:+      all its free types/classes are bound in this SCC or earlier ones++(5) We make an initial TyClGroup, with empty group_tyclds, for any+    (orphan) instances that affect only imported types/classes++Steps (3) and (4) are done by the (mapAccumL mk_group) call.++Note [No dependencies on data instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   data family D a+   data instance D Int = D1+   data S = MkS (Proxy 'D1)++Here the declaration of S depends on the /data instance/ declaration+for 'D Int'.  That makes things a lot more complicated, especially+if the data instance is an associated type of an enclosing class instance.+(And the class instance might have several associated type instances+with different dependency structure!)++Ugh.  For now we simply don't allow promotion of data constructors for+data instances.  See Note [AFamDataCon: not promoting data family+constructors] in TcEnv+-}+++rnTyClDecls :: [TyClGroup GhcPs]+            -> RnM ([TyClGroup GhcRn], FreeVars)+-- Rename the declarations and do dependency analysis on them+rnTyClDecls tycl_ds+  = do { -- Rename the type/class, instance, and role declaraations+       ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)+       ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)+       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)+       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)++       -- Do SCC analysis on the type/class decls+       ; rdr_env <- getGlobalRdrEnv+       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs+             role_annot_env = mkRoleAnnotEnv role_annots+             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs++             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs+             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map++             first_group+               | null init_inst_ds = []+               | otherwise = [TyClGroup { group_ext    = noExtField+                                        , group_tyclds = []+                                        , group_kisigs = []+                                        , group_roles  = []+                                        , group_instds = init_inst_ds }]++             (final_inst_ds, groups)+                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs++             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`+                       foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`+                       foldr (plusFV . snd) emptyFVs kisigs_w_fvs++             all_groups = first_group ++ groups++       ; MASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map+                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )++       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)+       ; return (all_groups, all_fvs) }+  where+    mk_group :: RoleAnnotEnv+             -> KindSigEnv+             -> InstDeclFreeVarsMap+             -> SCC (LTyClDecl GhcRn)+             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)+    mk_group role_env kisig_env inst_map scc+      = (inst_map', group)+      where+        tycl_ds              = flattenSCC scc+        bndrs                = map (tcdName . unLoc) tycl_ds+        roles                = getRoleAnnots bndrs role_env+        kisigs               = getKindSigs   bndrs kisig_env+        (inst_ds, inst_map') = getInsts      bndrs inst_map+        group = TyClGroup { group_ext    = noExtField+                          , group_tyclds = tycl_ds+                          , group_kisigs = kisigs+                          , group_roles  = roles+                          , group_instds = inst_ds }++-- | Free variables of standalone kind signatures.+newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)++lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars+lookupKindSig_FV_Env (KindSig_FV_Env e) name+  = fromMaybe emptyFVs (lookupNameEnv e name)++-- | Standalone kind signatures.+type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)++mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)+mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)+  where+    kisig_env = mapNameEnv fst compound_env+    kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)+    compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)+      = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs++getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]+getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs++rnStandaloneKindSignatures+  :: NameSet  -- names of types and classes in the current TyClGroup+  -> [LStandaloneKindSig GhcPs]+  -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]+rnStandaloneKindSignatures tc_names kisigs+  = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs+             get_name = standaloneKindSigName . unLoc+       ; mapM_ dupKindSig_Err dup_kisigs+       ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups+       }++rnStandaloneKindSignature+  :: NameSet  -- names of types and classes in the current TyClGroup+  -> StandaloneKindSig GhcPs+  -> RnM (StandaloneKindSig GhcRn, FreeVars)+rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)+  = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures+        ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr+        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v+        ; let doc = StandaloneKindSigCtx (ppr v)+        ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki+        ; return (StandaloneKindSig noExtField new_v new_ki, fvs)+        }+  where+    standaloneKiSigErr :: SDoc+    standaloneKiSigErr =+      hang (text "Illegal standalone kind signature")+         2 (text "Did you mean to enable StandaloneKindSignatures?")+rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec++depAnalTyClDecls :: GlobalRdrEnv+                 -> KindSig_FV_Env+                 -> [(LTyClDecl GhcRn, FreeVars)]+                 -> [SCC (LTyClDecl GhcRn)]+-- See Note [Dependency analysis of type, class, and instance decls]+depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs+  = stronglyConnCompFromEdgedVerticesUniq edges+  where+    edges :: [ Node Name (LTyClDecl GhcRn) ]+    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))+            | (d, fvs) <- ds_w_fvs,+              let { name = tcdName (unLoc d)+                  ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name+                  ; deps = fvs `plusFV` kisig_fvs+                  }+            ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic+            -- even if the edges are in nondeterministic order as explained+            -- in Note [Deterministic SCC] in Digraph.++toParents :: GlobalRdrEnv -> NameSet -> NameSet+toParents rdr_env ns+  = nonDetFoldUniqSet add emptyNameSet ns+  -- It's OK to use nonDetFoldUFM because we immediately forget the+  -- ordering by creating a set+  where+    add n s = extendNameSet s (getParent rdr_env n)++getParent :: GlobalRdrEnv -> Name -> Name+getParent rdr_env n+  = case lookupGRE_Name rdr_env n of+      Just gre -> case gre_par gre of+                    ParentIs  { par_is = p } -> p+                    FldParent { par_is = p } -> p+                    _                        -> n+      Nothing -> n+++{- ******************************************************+*                                                       *+       Role annotations+*                                                       *+****************************************************** -}++-- | Renames role annotations, returning them as the values in a NameEnv+-- and checks for duplicate role annotations.+-- It is quite convenient to do both of these in the same place.+-- See also Note [Role annotations in the renamer]+rnRoleAnnots :: NameSet+             -> [LRoleAnnotDecl GhcPs]+             -> RnM [LRoleAnnotDecl GhcRn]+rnRoleAnnots tc_names role_annots+  = do {  -- Check for duplicates *before* renaming, to avoid+          -- lumping together all the unboundNames+         let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots+             get_name = roleAnnotDeclName . unLoc+       ; mapM_ dupRoleAnnotErr dup_annots+       ; mapM (wrapLocM rn_role_annot1) no_dups }+  where+    rn_role_annot1 (RoleAnnotDecl _ tycon roles)+      = do {  -- the name is an *occurrence*, but look it up only in the+              -- decls defined in this group (see #10263)+             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)+                                          (text "role annotation")+                                          tycon+           ; return $ RoleAnnotDecl noExtField tycon' roles }+    rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec++dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()+dupRoleAnnotErr list+  = addErrAt loc $+    hang (text "Duplicate role annotations for" <+>+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)+       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)+    where+      sorted_list = NE.sortBy cmp_annot list+      ((L loc first_decl) :| _) = sorted_list++      pp_role_annot (L loc decl) = hang (ppr decl)+                                      4 (text "-- written at" <+> ppr loc)++      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2++dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()+dupKindSig_Err list+  = addErrAt loc $+    hang (text "Duplicate standalone kind signatures for" <+>+          quotes (ppr $ standaloneKindSigName first_decl) <> colon)+       2 (vcat $ map pp_kisig $ NE.toList sorted_list)+    where+      sorted_list = NE.sortBy cmp_loc list+      ((L loc first_decl) :| _) = sorted_list++      pp_kisig (L loc decl) =+        hang (ppr decl) 4 (text "-- written at" <+> ppr loc)++      cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2++{- Note [Role annotations in the renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must ensure that a type's role annotation is put in the same group as the+proper type declaration. This is because role annotations are needed during+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that+type, if any. Then, this map can be used to add the role annotations to the+groups after dependency analysis.++This process checks for duplicate role annotations, where we must be careful+to do the check *before* renaming to avoid calling all unbound names duplicates+of one another.++The renaming process, as usual, might identify and report errors for unbound+names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using+lookupGlobalOccRn led to #8485).+-}+++{- ******************************************************+*                                                       *+       Dependency info for instances+*                                                       *+****************************************************** -}++----------------------------------------------------------+-- | 'InstDeclFreeVarsMap is an association of an+--   @InstDecl@ with @FreeVars@. The @FreeVars@ are+--   the tycon names that are both+--     a) free in the instance declaration+--     b) bound by this group of type/class/instance decls+type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]++-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the+--   @FreeVars@ which are *not* the binders of a @TyClDecl@.+mkInstDeclFreeVarsMap :: GlobalRdrEnv+                      -> NameSet+                      -> [(LInstDecl GhcRn, FreeVars)]+                      -> InstDeclFreeVarsMap+mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs+  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)+    | (inst_decl, fvs) <- inst_ds_fvs ]++-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the+--   @InstDeclFreeVarsMap@ with these entries removed.+-- We call (getInsts tcs instd_map) when we've completed the declarations+-- for 'tcs'.  The call returns (inst_decls, instd_map'), where+--   inst_decls are the instance declarations all of+--              whose free vars are now defined+--   instd_map' is the inst-decl map with 'tcs' removed from+--               the free-var set+getInsts :: [Name] -> InstDeclFreeVarsMap+         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)+getInsts bndrs inst_decl_map+  = partitionWith pick_me inst_decl_map+  where+    pick_me :: (LInstDecl GhcRn, FreeVars)+            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)+    pick_me (decl, fvs)+      | isEmptyNameSet depleted_fvs = Left decl+      | otherwise                   = Right (decl, depleted_fvs)+      where+        depleted_fvs = delFVs bndrs fvs++{- ******************************************************+*                                                       *+         Renaming a type or class declaration+*                                                       *+****************************************************** -}++rnTyClDecl :: TyClDecl GhcPs+           -> RnM (TyClDecl GhcRn, FreeVars)++-- All flavours of top-level type family declarations ("type family", "newtype+-- family", and "data family")+rnTyClDecl (FamDecl { tcdFam = fam })+  = do { (fam', fvs) <- rnFamDecl Nothing fam+       ; return (FamDecl noExtField fam', fvs) }++rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,+                      tcdFixity = fixity, tcdRhs = rhs })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; let kvs = extractHsTyRdrTyVarsKindVars rhs+             doc = TySynCtx tycon+       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->+    do { (rhs', fvs) <- rnTySyn doc rhs+       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'+                         , tcdFixity = fixity+                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }++-- "data", "newtype" declarations+rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec+rnTyClDecl (DataDecl+    { tcdLName = tycon, tcdTyVars = tyvars,+      tcdFixity = fixity,+      tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data+                                   , dd_kindSig = kind_sig} })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; let kvs = extractDataDefnKindVars defn+             doc = TyDataCtx tycon+       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->+    do { (defn', fvs) <- rnDataDefn doc defn+       ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig+       ; let rn_info = DataDeclRn { tcdDataCusk = cusk+                                  , tcdFVs      = fvs }+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)+       ; return (DataDecl { tcdLName    = tycon'+                          , tcdTyVars   = tyvars'+                          , tcdFixity   = fixity+                          , tcdDataDefn = defn'+                          , tcdDExt     = rn_info }, fvs) } }++rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,+                        tcdTyVars = tyvars, tcdFixity = fixity,+                        tcdFDs = fds, tcdSigs = sigs,+                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,+                        tcdDocs = docs})+  = do  { lcls' <- lookupLocatedTopBndrRn lcls+        ; let cls' = unLoc lcls'+              kvs = []  -- No scoped kind vars except those in+                        -- kind signatures on the tyvars++        -- Tyvars scope over superclass context and method signatures+        ; ((tyvars', context', fds', ats'), stuff_fvs)+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do+                  -- Checks for distinct tyvars+             { (context', cxt_fvs) <- rnContext cls_doc context+             ; fds'  <- rnFds fds+                         -- The fundeps have no free variables+             ; (ats', fv_ats) <- rnATDecls cls' ats+             ; let fvs = cxt_fvs     `plusFV`+                         fv_ats+             ; return ((tyvars', context', fds', ats'), fvs) }++        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs++        -- No need to check for duplicate associated type decls+        -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn++        -- Check the signatures+        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).+        ; let sig_rdr_names_w_locs =+                [op | L _ (ClassOpSig _ False ops _) <- sigs+                    , op <- ops]+        ; checkDupRdrNames sig_rdr_names_w_locs+                -- Typechecker is responsible for checking that we only+                -- give default-method bindings for things in this class.+                -- The renamer *could* check this for class decls, but can't+                -- for instance decls.++        -- The newLocals call is tiresome: given a generic class decl+        --      class C a where+        --        op :: a -> a+        --        op {| x+y |} (Inl a) = ...+        --        op {| x+y |} (Inr b) = ...+        --        op {| a*b |} (a*b)   = ...+        -- we want to name both "x" tyvars with the same unique, so that they are+        -- easy to group together in the typechecker.+        ; (mbinds', sigs', meth_fvs)+            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs+                -- No need to check for duplicate method signatures+                -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn+                -- and the methods are already in scope++  -- Haddock docs+        ; docs' <- mapM (wrapLocM rnDocDecl) docs++        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs+        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',+                              tcdTyVars = tyvars', tcdFixity = fixity,+                              tcdFDs = fds', tcdSigs = sigs',+                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',+                              tcdDocs = docs', tcdCExt = all_fvs },+                  all_fvs ) }+  where+    cls_doc  = ClassDeclCtx lcls++rnTyClDecl (XTyClDecl nec) = noExtCon nec++-- Does the data type declaration include a CUSK?+data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool+data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do+  { -- See Note [Unlifted Newtypes and CUSKs], and for a broader+    -- picture, see Note [Implementation of UnliftedNewtypes].+  ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+  ; let non_cusk_newtype+          | NewType <- new_or_data =+              unlifted_newtypes && isNothing kind_sig+          | otherwise = False+    -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls+  ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype+  }++{- Note [Unlifted Newtypes and CUSKs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When unlifted newtypes are enabled, a newtype must have a kind signature+in order to be considered have a CUSK. This is because the flow of+kind inference works differently. Consider:++  newtype Foo = FooC Int++When UnliftedNewtypes is disabled, we decide that Foo has kind+`TYPE 'LiftedRep` without looking inside the data constructor. So, we+can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,+we fill in the kind of Foo as a metavar that gets solved by unification+with the kind of the field inside FooC (that is, Int, whose kind is+`TYPE 'LiftedRep`). But since we have to look inside the data constructors+to figure out the kind signature of Foo, it does not have a CUSK.++See Note [Implementation of UnliftedNewtypes] for where this fits in to+the broader picture of UnliftedNewtypes.+-}++-- "type" and "type instance" declarations+rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)+rnTySyn doc rhs = rnLHsType doc rhs++rnDataDefn :: HsDocContext -> HsDataDefn GhcPs+           -> RnM (HsDataDefn GhcRn, FreeVars)+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                           , dd_ctxt = context, dd_cons = condecls+                           , dd_kindSig = m_sig, dd_derivs = derivs })+  = do  { checkTc (h98_style || null (unLoc context))+                  (badGadtStupidTheta doc)++        ; (m_sig', sig_fvs) <- case m_sig of+             Just sig -> first Just <$> rnLHsKind doc sig+             Nothing  -> return (Nothing, emptyFVs)+        ; (context', fvs1) <- rnContext doc context+        ; (derivs',  fvs3) <- rn_derivs derivs++        -- For the constructor declarations, drop the LocalRdrEnv+        -- in the GADT case, where the type variables in the declaration+        -- do not scope over the constructor signatures+        -- data T a where { T1 :: forall b. b-> b }+        ; let { zap_lcl_env | h98_style = \ thing -> thing+                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }+        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls+           -- No need to check for duplicate constructor decls+           -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn++        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`+                        con_fvs `plusFV` sig_fvs+        ; return ( HsDataDefn { dd_ext = noExtField+                              , dd_ND = new_or_data, dd_cType = cType+                              , dd_ctxt = context', dd_kindSig = m_sig'+                              , dd_cons = condecls'+                              , dd_derivs = derivs' }+                 , all_fvs )+        }+  where+    h98_style = case condecls of  -- Note [Stupid theta]+                     (L _ (ConDeclGADT {})) : _  -> False+                     _                           -> True++    rn_derivs (L loc ds)+      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies+           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)+               multipleDerivClausesErr+           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds+           ; return (L loc ds', fvs) }+rnDataDefn _ (XHsDataDefn nec) = noExtCon nec++warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)+                 -> SrcSpan+                 -> RnM ()+warnNoDerivStrat mds loc+  = do { dyn_flags <- getDynFlags+       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $+           case mds of+             Nothing -> addWarnAt+               (Reason Opt_WarnMissingDerivingStrategies)+               loc+               (if xopt LangExt.DerivingStrategies dyn_flags+                 then no_strat_warning+                 else no_strat_warning $+$ deriv_strat_nenabled+               )+             _ -> pure ()+       }+  where+    no_strat_warning :: SDoc+    no_strat_warning = text "No deriving strategy specified. Did you want stock"+                       <> text ", newtype, or anyclass?"+    deriv_strat_nenabled :: SDoc+    deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."++rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs+                    -> RnM (LHsDerivingClause GhcRn, FreeVars)+rnLHsDerivingClause doc+                (L loc (HsDerivingClause+                              { deriv_clause_ext = noExtField+                              , deriv_clause_strategy = dcs+                              , deriv_clause_tys = L loc' dct }))+  = do { (dcs', dct', fvs)+           <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct+       ; warnNoDerivStrat dcs' loc+       ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField+                                        , deriv_clause_strategy = dcs'+                                        , deriv_clause_tys = L loc' dct' })+              , fvs ) }+rnLHsDerivingClause _ (L _ (XHsDerivingClause nec))+  = noExtCon nec++rnLDerivStrategy :: forall a.+                    HsDocContext+                 -> Maybe (LDerivStrategy GhcPs)+                 -> RnM (a, FreeVars)+                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)+rnLDerivStrategy doc mds thing_inside+  = case mds of+      Nothing -> boring_case Nothing+      Just (L loc ds) ->+        setSrcSpan loc $ do+          (ds', thing, fvs) <- rn_deriv_strat ds+          pure (Just (L loc ds'), thing, fvs)+  where+    rn_deriv_strat :: DerivStrategy GhcPs+                   -> RnM (DerivStrategy GhcRn, a, FreeVars)+    rn_deriv_strat ds = do+      let extNeeded :: LangExt.Extension+          extNeeded+            | ViaStrategy{} <- ds+            = LangExt.DerivingVia+            | otherwise+            = LangExt.DerivingStrategies++      unlessXOptM extNeeded $+        failWith $ illegalDerivStrategyErr ds++      case ds of+        StockStrategy    -> boring_case StockStrategy+        AnyclassStrategy -> boring_case AnyclassStrategy+        NewtypeStrategy  -> boring_case NewtypeStrategy+        ViaStrategy via_ty ->+          do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty+             let HsIB { hsib_ext  = via_imp_tvs+                      , hsib_body = via_body } = via_ty'+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body+                 via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs+                 via_tvs = via_imp_tvs ++ via_exp_tvs+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside+             pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)++    boring_case :: ds -> RnM (ds, a, FreeVars)+    boring_case ds = do+      (thing, fvs) <- thing_inside+      pure (ds, thing, fvs)++badGadtStupidTheta :: HsDocContext -> SDoc+badGadtStupidTheta _+  = vcat [text "No context is allowed on a GADT-style data declaration",+          text "(You can put a context on each constructor, though.)"]++illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc+illegalDerivStrategyErr ds+  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds+         , text enableStrategy ]++  where+    enableStrategy :: String+    enableStrategy+      | ViaStrategy{} <- ds+      = "Use DerivingVia to enable this extension"+      | otherwise+      = "Use DerivingStrategies to enable this extension"++multipleDerivClausesErr :: SDoc+multipleDerivClausesErr+  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"+         , text "Use DerivingStrategies to allow this" ]++rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested+                        --             inside an *class decl* for cls+                        --             used for associated types+          -> FamilyDecl GhcPs+          -> RnM (FamilyDecl GhcRn, FreeVars)+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars+                             , fdFixity = fixity+                             , fdInfo = info, fdResultSig = res_sig+                             , fdInjectivityAnn = injectivity })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; ((tyvars', res_sig', injectivity'), fv1) <-+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->+            do { let rn_sig = rnFamResultSig doc+               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig+               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')+                                          injectivity+               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }+       ; (info', fv2) <- rn_info tycon' info+       ; return (FamilyDecl { fdExt = noExtField+                            , fdLName = tycon', fdTyVars = tyvars'+                            , fdFixity = fixity+                            , fdInfo = info', fdResultSig = res_sig'+                            , fdInjectivityAnn = injectivity' }+                , fv1 `plusFV` fv2) }+  where+     doc = TyFamilyCtx tycon+     kvs = extractRdrKindSigVars res_sig++     ----------------------+     rn_info :: Located Name+             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)+     rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns))+       = do { (eqns', fvs)+                <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))+                                          -- no class context+                          eqns+            ; return (ClosedTypeFamily (Just eqns'), fvs) }+     rn_info _ (ClosedTypeFamily Nothing)+       = return (ClosedTypeFamily Nothing, emptyFVs)+     rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)+     rn_info _ DataFamily     = return (DataFamily, emptyFVs)+rnFamDecl _ (XFamilyDecl nec) = noExtCon nec++rnFamResultSig :: HsDocContext+               -> FamilyResultSig GhcPs+               -> RnM (FamilyResultSig GhcRn, FreeVars)+rnFamResultSig _ (NoSig _)+   = return (NoSig noExtField, emptyFVs)+rnFamResultSig doc (KindSig _ kind)+   = do { (rndKind, ftvs) <- rnLHsKind doc kind+        ;  return (KindSig noExtField rndKind, ftvs) }+rnFamResultSig doc (TyVarSig _ tvbndr)+   = do { -- `TyVarSig` tells us that user named the result of a type family by+          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to+          -- be sure that the supplied result name is not identical to an+          -- already in-scope type variable from an enclosing class.+          --+          --  Example of disallowed declaration:+          --         class C a b where+          --            type F b = a | a -> b+          rdr_env <- getLocalRdrEnv+       ;  let resName = hsLTyVarName tvbndr+       ;  when (resName `elemLocalRdrEnv` rdr_env) $+          addErrAt (getLoc tvbndr) $+                     (hsep [ text "Type variable", quotes (ppr resName) <> comma+                           , text "naming a type family result,"+                           ] $$+                      text "shadows an already bound type variable")++       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for+                                      -- scoping checks that are irrelevant here+                          tvbndr $ \ tvbndr' ->+         return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }+rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec++-- Note [Renaming injectivity annotation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- During renaming of injectivity annotation we have to make several checks to+-- make sure that it is well-formed.  At the moment injectivity annotation+-- consists of a single injectivity condition, so the terms "injectivity+-- annotation" and "injectivity condition" might be used interchangeably.  See+-- Note [Injectivity annotation] for a detailed discussion of currently allowed+-- injectivity annotations.+--+-- Checking LHS is simple because the only type variable allowed on the LHS of+-- injectivity condition is the variable naming the result in type family head.+-- Example of disallowed annotation:+--+--     type family Foo a b = r | b -> a+--+-- Verifying RHS of injectivity consists of checking that:+--+--  1. only variables defined in type family head appear on the RHS (kind+--     variables are also allowed).  Example of disallowed annotation:+--+--        type family Foo a = r | r -> b+--+--  2. for associated types the result variable does not shadow any of type+--     class variables. Example of disallowed annotation:+--+--        class Foo a b where+--           type F a = b | b -> a+--+-- Breaking any of these assumptions results in an error.++-- | Rename injectivity annotation. Note that injectivity annotation is just the+-- part after the "|".  Everything that appears before it is renamed in+-- rnFamDecl.+rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in+                                               --   type family head+                 -> LFamilyResultSig GhcRn     -- ^ Result signature+                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation+                 -> RnM (LInjectivityAnn GhcRn)+rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))+                 (L srcSpan (InjectivityAnn injFrom injTo))+ = do+   { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)+          <- askNoErrs $+             bindLocalNames [hsLTyVarName resTv] $+             -- The return type variable scopes over the injectivity annotation+             -- e.g.   type family F a = (r::*) | r -> a+             do { injFrom' <- rnLTyVar injFrom+                ; injTo'   <- mapM rnLTyVar injTo+                ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }++   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs+         resName  = hsLTyVarName resTv+         -- See Note [Renaming injectivity annotation]+         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))+         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames++   -- if renaming of type variables ended with errors (eg. there were+   -- not-in-scope variables) don't check the validity of injectivity+   -- annotation. This gives better error messages.+   ; when (noRnErrors && not lhsValid) $+        addErrAt (getLoc injFrom)+              ( vcat [ text $ "Incorrect type variable on the LHS of "+                           ++ "injectivity condition"+              , nest 5+              ( vcat [ text "Expected :" <+> ppr resName+                     , text "Actual   :" <+> ppr injFrom ])])++   ; when (noRnErrors && not (Set.null rhsValid)) $+      do { let errorVars = Set.toList rhsValid+         ; addErrAt srcSpan $ ( hsep+                        [ text "Unknown type variable" <> plural errorVars+                        , text "on the RHS of injectivity condition:"+                        , interpp'SP errorVars ] ) }++   ; return injDecl' }++-- We can only hit this case when the user writes injectivity annotation without+-- naming the result:+--+--   type family F a | result -> a+--   type family F a :: * | result -> a+--+-- So we rename injectivity annotation like we normally would except that+-- this time we expect "result" to be reported not in scope by rnLTyVar.+rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =+   setSrcSpan srcSpan $ do+   (injDecl', _) <- askNoErrs $ do+     injFrom' <- rnLTyVar injFrom+     injTo'   <- mapM rnLTyVar injTo+     return $ L srcSpan (InjectivityAnn injFrom' injTo')+   return $ injDecl'++{-+Note [Stupid theta]+~~~~~~~~~~~~~~~~~~~+#3850 complains about a regression wrt 6.10 for+     data Show a => T a+There is no reason not to allow the stupid theta if there are no data+constructors.  It's still stupid, but does no harm, and I don't want+to cause programs to break unnecessarily (notably HList).  So if there+are no data constructors we allow h98_style = True+-}+++{- *****************************************************+*                                                      *+     Support code for type/data declarations+*                                                      *+***************************************************** -}++---------------+wrongTyFamName :: Name -> Name -> SDoc+wrongTyFamName fam_tc_name eqn_tc_name+  = hang (text "Mismatched type name in type family instance.")+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name+               , text "  Actual:" <+> ppr eqn_tc_name ])++-----------------+rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)++rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs+                           , con_mb_cxt = mcxt, con_args = args+                           , con_doc = mb_doc })+  = do  { _        <- addLocM checkConName name+        ; new_name <- lookupLocatedTopBndrRn name+        ; mb_doc'  <- rnMbLHsDoc mb_doc++        -- We bind no implicit binders here; this is just like+        -- a nested HsForAllTy.  E.g. consider+        --         data T a = forall (b::k). MkT (...)+        -- The 'k' will already be in scope from the bindHsQTyVars+        -- for the data decl itself. So we'll get+        --         data T {k} a = ...+        -- And indeed we may later discover (a::k).  But that's the+        -- scoping we get.  So no implicit binders at the existential forall++        ; let ctxt = ConDeclCtx [new_name]+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))+                            Nothing ex_tvs $ \ new_ex_tvs ->+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args+        ; let all_fvs  = fvs1 `plusFV` fvs2+        ; traceRn "rnConDecl" (ppr name <+> vcat+             [ text "ex_tvs:" <+> ppr ex_tvs+             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])++        ; return (decl { con_ext = noExtField+                       , con_name = new_name, con_ex_tvs = new_ex_tvs+                       , con_mb_cxt = new_context, con_args = new_args+                       , con_doc = mb_doc' },+                  all_fvs) }}++rnConDecl decl@(ConDeclGADT { con_names   = names+                            , con_forall  = L _ explicit_forall+                            , con_qvars   = qtvs+                            , con_mb_cxt  = mcxt+                            , con_args    = args+                            , con_res_ty  = res_ty+                            , con_doc = mb_doc })+  = do  { mapM_ (addLocM checkConName) names+        ; new_names <- mapM lookupLocatedTopBndrRn names+        ; mb_doc'   <- rnMbLHsDoc mb_doc++        ; let explicit_tkvs = hsQTvExplicit qtvs+              theta         = hsConDeclTheta mcxt+              arg_tys       = hsConDeclArgTys args++          -- We must ensure that we extract the free tkvs in left-to-right+          -- order of their appearance in the constructor type.+          -- That order governs the order the implicitly-quantified type+          -- variable, and hence the order needed for visible type application+          -- See #14808.+              free_tkvs = extractHsTvBndrs explicit_tkvs $+                          extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])++              ctxt    = ConDeclCtx new_names+              mb_ctxt = Just (inHsDocContext ctxt)++        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )+        ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty++        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3+              (args', res_ty')+                  = case args of+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)+                      RecCon {}    -> (new_args, new_res_ty)+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty+                                   -> ASSERT( null as )+                                      -- See Note [GADT abstract syntax] in GHC.Hs.Decls+                                      (PrefixCon arg_tys, final_res_ty)++              new_qtvs =  HsQTvs { hsq_ext = implicit_tkvs+                                 , hsq_explicit  = explicit_tkvs }++        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)+        ; return (decl { con_g_ext = noExtField, con_names = new_names+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt+                       , con_args = args', con_res_ty = res_ty'+                       , con_doc = mb_doc' },+                  all_fvs) } }++rnConDecl (XConDecl nec) = noExtCon nec+++rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnMbContext _    Nothing    = return (Nothing, emptyFVs)+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt+                                ; return (Just ctx',fvs) }++rnConDeclDetails+   :: Name+   -> HsDocContext+   -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])+   -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),+           FreeVars)+rnConDeclDetails _ doc (PrefixCon tys)+  = do { (new_tys, fvs) <- rnLHsTypes doc tys+       ; return (PrefixCon new_tys, fvs) }++rnConDeclDetails _ doc (InfixCon ty1 ty2)+  = do { (new_ty1, fvs1) <- rnLHsType doc ty1+       ; (new_ty2, fvs2) <- rnLHsType doc ty2+       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }++rnConDeclDetails con doc (RecCon (L l fields))+  = do  { fls <- lookupConstructorFields con+        ; (new_fields, fvs) <- rnConDeclFields doc fls fields+                -- No need to check for duplicate fields+                -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn+        ; return (RecCon (L l new_fields), fvs) }++-------------------------------------------------++-- | Brings pattern synonym names and also pattern synonym selectors+-- from record pattern synonyms into scope.+extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv+                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a+extendPatSynEnv val_decls local_fix_env thing = do {+     names_with_fls <- new_ps val_decls+   ; let pat_syn_bndrs = concat [ name: map flSelector fields+                                | (name, fields) <- names_with_fls ]+   ; let avails = map avail pat_syn_bndrs+   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env++   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls+         final_gbl_env = gbl_env { tcg_field_env = field_env' }+   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }+  where+    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]+    new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds+    new_ps _ = panic "new_ps"++    new_ps' :: LHsBindLR GhcPs GhcPs+            -> [(Name, [FieldLabel])]+            -> TcM [(Name, [FieldLabel])]+    new_ps' bind names+      | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n+                                       , psb_args = RecCon as }))) <- bind+      = do+          bnd_name <- newTopSrcBinder (L bind_loc n)+          let rnames = map recordPatSynSelectorId as+              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs+              mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name))+              field_occs =  map mkFieldOcc rnames+          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs+          return ((bnd_name, flds): names)+      | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind+      = do+        bnd_name <- newTopSrcBinder (L bind_loc n)+        return ((bnd_name, []): names)+      | otherwise+      = return names++{-+*********************************************************+*                                                      *+\subsection{Support code to rename types}+*                                                      *+*********************************************************+-}++rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]+rnFds fds+  = mapM (wrapLocM rn_fds) fds+  where+    rn_fds (tys1, tys2)+      = do { tys1' <- rnHsTyVars tys1+           ; tys2' <- rnHsTyVars tys2+           ; return (tys1', tys2') }++rnHsTyVars :: [Located RdrName] -> RnM [Located Name]+rnHsTyVars tvs  = mapM rnHsTyVar tvs++rnHsTyVar :: Located RdrName -> RnM (Located Name)+rnHsTyVar (L l tyvar) = do+  tyvar' <- lookupOccRn tyvar+  return (L l tyvar')++{-+*********************************************************+*                                                      *+        findSplice+*                                                      *+*********************************************************++This code marches down the declarations, looking for the first+Template Haskell splice.  As it does so it+        a) groups the declarations into a HsGroup+        b) runs any top-level quasi-quotes+-}++findSplice :: [LHsDecl GhcPs]+           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))+findSplice ds = addl emptyRdrGroup ds++addl :: HsGroup GhcPs -> [LHsDecl GhcPs]+     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))+-- This stuff reverses the declarations (again) but it doesn't matter+addl gp []           = return (gp, Nothing)+addl gp (L l d : ds) = add gp l d ds+++add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]+    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))++-- #10047: Declaration QuasiQuoters are expanded immediately, without+--         causing a group split+add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds+  = do { (ds', _) <- rnTopSpliceDecls qq+       ; addl gp (ds' ++ ds)+       }++add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds+  = do { -- We've found a top-level splice.  If it is an *implicit* one+         -- (i.e. a naked top level expression)+         case flag of+           ExplicitSplice -> return ()+           ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell+                                ; unless th_on $ setSrcSpan loc $+                                  failWith badImplicitSplice }++       ; return (gp, Just (splice, ds)) }+  where+    badImplicitSplice = text "Parse error: module header, import declaration"+                     $$ text "or top-level declaration expected."+                     -- The compiler should suggest the above, and not using+                     -- TemplateHaskell since the former suggestion is more+                     -- relevant to the larger base of users.+                     -- See #12146 for discussion.++-- Class declarations: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds+  = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds++-- Signatures: fixity sigs go a different place than all others+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds+  = addl (gp {hs_fixds = L l f : ts}) ds++-- Standalone kind signatures: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds+  = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds++add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds+  = addl (gp {hs_valds = add_sig (L l d) ts}) ds++-- Value declarations: use add_bind+add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds+  = addl (gp { hs_valds = add_bind (L l d) ts }) ds++-- Role annotations: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds+  = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds++-- NB instance declarations go into TyClGroups. We throw them into the first+-- group, just as we do for the TyClD case. The renamer will go on to group+-- and order them later.+add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds+  = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds++-- The rest are routine+add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds+  = addl (gp { hs_derivds = L l d : ts }) ds+add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds+  = addl (gp { hs_defds = L l d : ts }) ds+add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds+  = addl (gp { hs_fords = L l d : ts }) ds+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds+  = addl (gp { hs_warnds = L l d : ts }) ds+add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds+  = addl (gp { hs_annds = L l d : ts }) ds+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds+  = addl (gp { hs_ruleds = L l d : ts }) ds+add gp l (DocD _ d) ds+  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec+add (HsGroup {}) _ (XHsDecl nec)                 _ = noExtCon nec+add (XHsGroup nec) _ _                           _ = noExtCon nec++add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]+          -> [TyClGroup (GhcPass p)]+add_tycld d []       = [TyClGroup { group_ext    = noExtField+                                  , group_tyclds = [d]+                                  , group_kisigs = []+                                  , group_roles  = []+                                  , group_instds = []+                                  }+                       ]+add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)+  = ds { group_tyclds = d : tyclds } : dss+add_tycld _ (XTyClGroup nec: _) = noExtCon nec++add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]+          -> [TyClGroup (GhcPass p)]+add_instd d []       = [TyClGroup { group_ext    = noExtField+                                  , group_tyclds = []+                                  , group_kisigs = []+                                  , group_roles  = []+                                  , group_instds = [d]+                                  }+                       ]+add_instd d (ds@(TyClGroup { group_instds = instds }):dss)+  = ds { group_instds = d : instds } : dss+add_instd _ (XTyClGroup nec: _) = noExtCon nec++add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]+               -> [TyClGroup (GhcPass p)]+add_role_annot d [] = [TyClGroup { group_ext    = noExtField+                                 , group_tyclds = []+                                 , group_kisigs = []+                                 , group_roles  = [d]+                                 , group_instds = []+                                 }+                      ]+add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)+  = tycls { group_roles = d : roles } : rest+add_role_annot _ (XTyClGroup nec: _) = noExtCon nec++add_kisig :: LStandaloneKindSig (GhcPass p)+         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]+add_kisig d [] = [TyClGroup { group_ext    = noExtField+                            , group_tyclds = []+                            , group_kisigs = [d]+                            , group_roles  = []+                            , group_instds = []+                            }+                 ]+add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)+  = tycls { group_kisigs = d : kisigs } : rest+add_kisig _ (XTyClGroup nec : _) = noExtCon nec++add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs+add_bind _ (XValBindsLR {})     = panic "RdrHsSyn:add_bind"++add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)+add_sig _ (XValBindsLR {})     = panic "RdrHsSyn:add_sig"
+ compiler/GHC/Rename/Splice.hs view
@@ -0,0 +1,904 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Rename.Splice (+        rnTopSpliceDecls,+        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,+        rnBracket,+        checkThLocalName+        , traceSplice, SpliceInfo(..)+  ) where++#include "HsVersions.h"++import GhcPrelude++import Name+import NameSet+import GHC.Hs+import RdrName+import TcRnMonad++import GHC.Rename.Env+import GHC.Rename.Utils   ( HsDocContext(..), newLocalBndrRn )+import GHC.Rename.Unbound ( isUnboundName )+import GHC.Rename.Source  ( rnSrcDecls, findSplice )+import GHC.Rename.Pat     ( rnPat )+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )+import Outputable+import Module+import SrcLoc+import GHC.Rename.Types ( rnLHsType )++import Control.Monad    ( unless, when )++import {-# SOURCE #-} GHC.Rename.Expr   ( rnLExpr )++import TcEnv            ( checkWellStaged )+import THNames          ( liftName )++import DynFlags+import FastString+import ErrUtils         ( dumpIfSet_dyn_printer, DumpFormat (..) )+import TcEnv            ( tcMetaTy )+import Hooks+import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName+                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )++import {-# SOURCE #-} TcExpr   ( tcPolyExpr )+import {-# SOURCE #-} TcSplice+    ( runMetaD+    , runMetaE+    , runMetaP+    , runMetaT+    , tcTopSpliceExpr+    )++import TcHsSyn++import GHCi.RemoteTypes ( ForeignRef )+import qualified Language.Haskell.TH as TH (Q)++import qualified GHC.LanguageExtensions as LangExt++{-+************************************************************************+*                                                                      *+        Template Haskell brackets+*                                                                      *+************************************************************************+-}++rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnBracket e br_body+  = addErrCtxt (quotationCtxtDoc br_body) $+    do { -- Check that -XTemplateHaskellQuotes is enabled and available+         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes+       ; unless thQuotesEnabled $+           failWith ( vcat+                      [ text "Syntax error on" <+> ppr e+                      , text ("Perhaps you intended to use TemplateHaskell"+                              ++ " or TemplateHaskellQuotes") ] )++         -- Check for nested brackets+       ; cur_stage <- getStage+       ; case cur_stage of+           { Splice Typed   -> checkTc (isTypedBracket br_body)+                                       illegalUntypedBracket+           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))+                                       illegalTypedBracket+           ; RunSplice _    ->+               -- See Note [RunSplice ThLevel] in "TcRnTypes".+               pprPanic "rnBracket: Renaming bracket when running a splice"+                        (ppr e)+           ; Comp           -> return ()+           ; Brack {}       -> failWithTc illegalBracket+           }++         -- Brackets are desugared to code that mentions the TH package+       ; recordThUse++       ; case isTypedBracket br_body of+            True  -> do { traceRn "Renaming typed TH bracket" empty+                        ; (body', fvs_e) <-+                          setStage (Brack cur_stage RnPendingTyped) $+                                   rn_bracket cur_stage br_body+                        ; return (HsBracket noExtField body', fvs_e) }++            False -> do { traceRn "Renaming untyped TH bracket" empty+                        ; ps_var <- newMutVar []+                        ; (body', fvs_e) <-+                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $+                                   rn_bracket cur_stage br_body+                        ; pendings <- readMutVar ps_var+                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }+       }++rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)+rn_bracket outer_stage br@(VarBr x flg rdr_name)+  = do { name <- lookupOccRn rdr_name+       ; this_mod <- getModule++       ; when (flg && nameIsLocalOrFrom this_mod name) $+             -- Type variables can be quoted in TH. See #5721.+                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name+                    ; case mb_bind_lvl of+                        { Nothing -> return ()      -- Can happen for data constructors,+                                                    -- but nothing needs to be done for them++                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]+                             | isTopLevel top_lvl+                             -> when (isExternalName name) (keepAlive name)+                             | otherwise+                             -> do { traceRn "rn_bracket VarBr"+                                      (ppr name <+> ppr bind_lvl+                                                <+> ppr outer_stage)+                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)+                                             (quotedNameStageErr br) }+                        }+                    }+       ; return (VarBr x flg name, unitFV name) }++rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e+                            ; return (ExpBr x e', fvs) }++rn_bracket _ (PatBr x p)+  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)++rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                              ; return (TypBr x t', fvs) }++rn_bracket _ (DecBrL x decls)+  = do { group <- groupDecls decls+       ; gbl_env  <- getGblEnv+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }+                          -- The emptyDUs is so that we just collect uses for this+                          -- group alone in the call to rnSrcDecls below+       ; (tcg_env, group') <- setGblEnv new_gbl_env $+                              rnSrcDecls group++              -- Discard the tcg_env; it contains only extra info about fixity+        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$+                   ppr (duUses (tcg_dus tcg_env)))+        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }+  where+    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)+    groupDecls decls+      = do { (group, mb_splice) <- findSplice decls+           ; case mb_splice of+           { Nothing -> return group+           ; Just (splice, rest) ->+               do { group' <- groupDecls rest+                  ; let group'' = appendGroups group group'+                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }+                  }+           }}++rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"++rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e+                               ; return (TExpBr x e', fvs) }++rn_bracket _ (XBracket nec) = noExtCon nec++quotationCtxtDoc :: HsBracket GhcPs -> SDoc+quotationCtxtDoc br_body+  = hang (text "In the Template Haskell quotation")+         2 (ppr br_body)++illegalBracket :: SDoc+illegalBracket =+    text "Template Haskell brackets cannot be nested" <+>+    text "(without intervening splices)"++illegalTypedBracket :: SDoc+illegalTypedBracket =+    text "Typed brackets may only appear in typed splices."++illegalUntypedBracket :: SDoc+illegalUntypedBracket =+    text "Untyped brackets may only appear in untyped splices."++quotedNameStageErr :: HsBracket GhcPs -> SDoc+quotedNameStageErr br+  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br+        , text "must be used at the same stage at which it is bound" ]+++{-+*********************************************************+*                                                      *+                Splices+*                                                      *+*********************************************************++Note [Free variables of typed splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider renaming this:+        f = ...+        h = ...$(thing "f")...++where the splice is a *typed* splice.  The splice can expand into+literally anything, so when we do dependency analysis we must assume+that it might mention 'f'.  So we simply treat all locally-defined+names as mentioned by any splice.  This is terribly brutal, but I+don't see what else to do.  For example, it'll mean that every+locally-defined thing will appear to be used, so no unused-binding+warnings.  But if we miss the dependency, then we might typecheck 'h'+before 'f', and that will crash the type checker because 'f' isn't in+scope.++Currently, I'm not treating a splice as also mentioning every import,+which is a bit inconsistent -- but there are a lot of them.  We might+thereby get some bogus unused-import warnings, but we won't crash the+type checker.  Not very satisfactory really.++Note [Renamer errors]+~~~~~~~~~~~~~~~~~~~~~+It's important to wrap renamer calls in checkNoErrs, because the+renamer does not fail for out of scope variables etc. Instead it+returns a bogus term/type, so that it can report more than one error.+We don't want the type checker to see these bogus unbound variables.+-}++rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))+                                            -- Outside brackets, run splice+            -> (HsSplice GhcRn -> (PendingRnSplice, a))+                                            -- Inside brackets, make it pending+            -> HsSplice GhcPs+            -> RnM (a, FreeVars)+rnSpliceGen run_splice pend_splice splice+  = addErrCtxt (spliceCtxt splice) $ do+    { stage <- getStage+    ; case stage of+        Brack pop_stage RnPendingTyped+          -> do { checkTc is_typed_splice illegalUntypedSplice+                ; (splice', fvs) <- setStage pop_stage $+                                    rnSplice splice+                ; let (_pending_splice, result) = pend_splice splice'+                ; return (result, fvs) }++        Brack pop_stage (RnPendingUntyped ps_var)+          -> do { checkTc (not is_typed_splice) illegalTypedSplice+                ; (splice', fvs) <- setStage pop_stage $+                                    rnSplice splice+                ; let (pending_splice, result) = pend_splice splice'+                ; ps <- readMutVar ps_var+                ; writeMutVar ps_var (pending_splice : ps)+                ; return (result, fvs) }++        _ ->  do { (splice', fvs1) <- checkNoErrs $+                                      setStage (Splice splice_type) $+                                      rnSplice splice+                   -- checkNoErrs: don't attempt to run the splice if+                   -- renaming it failed; otherwise we get a cascade of+                   -- errors from e.g. unbound variables+                 ; (result, fvs2) <- run_splice splice'+                 ; return (result, fvs1 `plusFV` fvs2) } }+   where+     is_typed_splice = isTypedSplice splice+     splice_type = if is_typed_splice+                   then Typed+                   else Untyped++------------------++-- | Returns the result of running a splice and the modFinalizers collected+-- during the execution.+--+-- See Note [Delaying modFinalizers in untyped splices].+runRnSplice :: UntypedSpliceFlavour+            -> (LHsExpr GhcTc -> TcRn res)+            -> (res -> SDoc)    -- How to pretty-print res+                                -- Usually just ppr, but not for [Decl]+            -> HsSplice GhcRn   -- Always untyped+            -> TcRn (res, [ForeignRef (TH.Q ())])+runRnSplice flavour run_meta ppr_res splice+  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)++       ; let the_expr = case splice' of+                HsUntypedSplice _ _ _ e   ->  e+                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str+                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)+                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)+                HsSplicedT {}             -> pprPanic "runRnSplice" (ppr splice)+                XSplice nec               -> noExtCon nec++             -- Typecheck the expression+       ; meta_exp_ty   <- tcMetaTy meta_ty_name+       ; zonked_q_expr <- zonkTopLExpr =<<+                            tcTopSpliceExpr Untyped+                              (tcPolyExpr the_expr meta_exp_ty)++             -- Run the expression+       ; mod_finalizers_ref <- newTcRef []+       ; result <- setStage (RunSplice mod_finalizers_ref) $+                     run_meta zonked_q_expr+       ; mod_finalizers <- readTcRef mod_finalizers_ref+       ; traceSplice (SpliceInfo { spliceDescription = what+                                 , spliceIsDecl      = is_decl+                                 , spliceSource      = Just the_expr+                                 , spliceGenerated   = ppr_res result })++       ; return (result, mod_finalizers) }++  where+    meta_ty_name = case flavour of+                       UntypedExpSplice  -> expQTyConName+                       UntypedPatSplice  -> patQTyConName+                       UntypedTypeSplice -> typeQTyConName+                       UntypedDeclSplice -> decsQTyConName+    what = case flavour of+                  UntypedExpSplice  -> "expression"+                  UntypedPatSplice  -> "pattern"+                  UntypedTypeSplice -> "type"+                  UntypedDeclSplice -> "declarations"+    is_decl = case flavour of+                 UntypedDeclSplice -> True+                 _                 -> False++------------------+makePending :: UntypedSpliceFlavour+            -> HsSplice GhcRn+            -> PendingRnSplice+makePending flavour (HsUntypedSplice _ _ n e)+  = PendingRnSplice flavour n e+makePending flavour (HsQuasiQuote _ n quoter q_span quote)+  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)+makePending _ splice@(HsTypedSplice {})+  = pprPanic "makePending" (ppr splice)+makePending _ splice@(HsSpliced {})+  = pprPanic "makePending" (ppr splice)+makePending _ splice@(HsSplicedT {})+  = pprPanic "makePending" (ppr splice)+makePending _ (XSplice nec)+  = noExtCon nec++------------------+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString+                 -> LHsExpr GhcRn+-- Return the expression (quoter "...quote...")+-- which is what we must run in a quasi-quote+mkQuasiQuoteExpr flavour quoter q_span quote+  = L q_span $ HsApp noExtField (L q_span+             $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector)))+                                quoterExpr)+                    quoteExpr+  where+    quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter)+    quoteExpr  = L q_span $! HsLit noExtField $! HsString NoSourceText quote+    quote_selector = case flavour of+                       UntypedExpSplice  -> quoteExpName+                       UntypedPatSplice  -> quotePatName+                       UntypedTypeSplice -> quoteTypeName+                       UntypedDeclSplice -> quoteDecName++---------------------+rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)+-- Not exported...used for all+rnSplice (HsTypedSplice x hasParen splice_name expr)+  = do  { loc  <- getSrcSpanM+        ; n' <- newLocalBndrRn (L loc splice_name)+        ; (expr', fvs) <- rnLExpr expr+        ; return (HsTypedSplice x hasParen n' expr', fvs) }++rnSplice (HsUntypedSplice x hasParen splice_name expr)+  = do  { loc  <- getSrcSpanM+        ; n' <- newLocalBndrRn (L loc splice_name)+        ; (expr', fvs) <- rnLExpr expr+        ; return (HsUntypedSplice x hasParen n' expr', fvs) }++rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)+  = do  { loc  <- getSrcSpanM+        ; splice_name' <- newLocalBndrRn (L loc splice_name)++          -- Rename the quoter; akin to the HsVar case of rnExpr+        ; quoter' <- lookupOccRn quoter+        ; this_mod <- getModule+        ; when (nameIsLocalOrFrom this_mod quoter') $+          checkThLocalName quoter'++        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote+                                                             , unitFV quoter') }++rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)+rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)+rnSplice        (XSplice nec)   = noExtCon nec++---------------------+rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnSpliceExpr splice+  = rnSpliceGen run_expr_splice pend_expr_splice splice+  where+    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)+    pend_expr_splice rn_splice+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice)++    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)+    run_expr_splice rn_splice+      | isTypedSplice rn_splice   -- Run it later, in the type checker+      = do {  -- Ugh!  See Note [Splices] above+             traceRn "rnSpliceExpr: typed expression splice" empty+           ; lcl_rdr <- getLocalRdrEnv+           ; gbl_rdr <- getGlobalRdrEnv+           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr+                                                     , isLocalGRE gre]+                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)++           ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) }++      | otherwise  -- Run it here, see Note [Running splices in the Renamer]+      = do { traceRn "rnSpliceExpr: untyped expression splice" empty+           ; (rn_expr, mod_finalizers) <-+                runRnSplice UntypedExpSplice runMetaE ppr rn_splice+           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( HsPar noExtField $ HsSpliceE noExtField+                            . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                            . HsSplicedExpr <$>+                            lexpr3+                    , fvs)+           }++{- Note [Running splices in the Renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Splices used to be run in the typechecker, which led to (#4364). Since the+renamer must decide which expressions depend on which others, and it cannot+reliably do this for arbitrary splices, we used to conservatively say that+splices depend on all other expressions in scope. Unfortunately, this led to+the problem of cyclic type declarations seen in (#4364). Instead, by+running splices in the renamer, we side-step the problem of determining+dependencies: by the time the dependency analysis happens, any splices have+already been run, and expression dependencies can be determined as usual.++However, see (#9813), for an example where we would like to run splices+*after* performing dependency analysis (that is, after renaming). It would be+desirable to typecheck "non-splicy" expressions (those expressions that do not+contain splices directly or via dependence on an expression that does) before+"splicy" expressions, such that types/expressions within the same declaration+group would be available to `reify` calls, for example consider the following:++> module M where+>   data D = C+>   f = 1+>   g = $(mapM reify ['f, 'D, ''C] ...)++Compilation of this example fails since D/C/f are not in the type environment+and thus cannot be reified as they have not been typechecked by the time the+splice is renamed and thus run.++These requirements are at odds: we do not want to run splices in the renamer as+we wish to first determine dependencies and typecheck certain expressions,+making them available to reify, but cannot accurately determine dependencies+without running splices in the renamer!++Indeed, the conclusion of (#9813) was that it is not worth the complexity+to try and+ a) implement and maintain the code for renaming/typechecking non-splicy+    expressions before splicy expressions,+ b) explain to TH users which expressions are/not available to reify at any+    given point.++-}++{- Note [Delaying modFinalizers in untyped splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When splices run in the renamer, 'reify' does not have access to the local+type environment (#11832, [1]).++For instance, in++> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])++'reify' cannot find @x@, because the local type environment is not yet+populated. To address this, we allow 'reify' execution to be deferred with+'addModFinalizer'.++> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)+                    [| return () |]+                )++The finalizer is run with the local type environment when type checking is+complete.++Since the local type environment is not available in the renamer, we annotate+the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where+@e@ is the result of splicing and @finalizers@ are the finalizers that have been+collected during evaluation of the splice [3]. In our example,++> HsLet+>   (x = e)+>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]+>                          (HsSplicedExpr $ return ())+>   )++When the typechecker finds the annotation, it inserts the finalizers in the+global environment and exposes the current local environment to them [4, 5, 6].++> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]++References:++[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify+[2] 'rnSpliceExpr'+[3] 'TcSplice.qAddModFinalizer'+[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))+[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))+[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))++-}++----------------------+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)+rnSpliceType splice+  = rnSpliceGen run_type_splice pend_type_splice splice+  where+    pend_type_splice rn_splice+       = ( makePending UntypedTypeSplice rn_splice+         , HsSpliceTy noExtField rn_splice)++    run_type_splice rn_splice+      = do { traceRn "rnSpliceType: untyped type splice" empty+           ; (hs_ty2, mod_finalizers) <-+                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice+           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2+                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }+                                    -- checkNoErrs: see Note [Renamer errors]+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( HsParTy noExtField+                              $ HsSpliceTy noExtField+                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                              . HsSplicedTy <$>+                              hs_ty3+                    , fvs+                    ) }+              -- Wrap the result of the splice in parens so that we don't+              -- lose the outermost location set by runQuasiQuote (#7918)++{- Note [Partial Type Splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Partial Type Signatures are partially supported in TH type splices: only+anonymous wild cards are allowed.++  -- ToDo: SLPJ says: I don't understand all this++Normally, named wild cards are collected before renaming a (partial) type+signature. However, TH type splices are run during renaming, i.e. after the+initial traversal, leading to out of scope errors for named wild cards. We+can't just extend the initial traversal to collect the named wild cards in TH+type splices, as we'd need to expand them, which is supposed to happen only+once, during renaming.++Similarly, the extra-constraints wild card is handled right before renaming+too, and is therefore also not supported in a TH type splice. Another reason+to forbid extra-constraints wild cards in TH type splices is that a single+signature can contain many TH type splices, whereas it mustn't contain more+than one extra-constraints wild card. Enforcing would this be hard the way+things are currently organised.++Anonymous wild cards pose no problem, because they start out without names and+are given names during renaming. These names are collected right after+renaming. The names generated for anonymous wild cards in TH type splices will+thus be collected as well.++For more details about renaming wild cards, see GHC.Rename.Types.rnHsSigWcType++Note that partial type signatures are fully supported in TH declaration+splices, e.g.:++     [d| foo :: _ => _+         foo x y = x == y |]++This is because in this case, the partial type signature can be treated as a+whole signature, instead of as an arbitrary type.++-}+++----------------------+-- | Rename a splice pattern. See Note [rnSplicePat]+rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)+                                       , FreeVars)+rnSplicePat splice+  = rnSpliceGen run_pat_splice pend_pat_splice splice+  where+    pend_pat_splice :: HsSplice GhcRn ->+                       (PendingRnSplice, Either b (Pat GhcRn))+    pend_pat_splice rn_splice+      = (makePending UntypedPatSplice rn_splice+        , Right (SplicePat noExtField rn_splice))++    run_pat_splice :: HsSplice GhcRn ->+                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)+    run_pat_splice rn_splice+      = do { traceRn "rnSplicePat: untyped pattern splice" empty+           ; (pat, mod_finalizers) <-+                runRnSplice UntypedPatSplice runMetaP ppr rn_splice+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField)+                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)+                              . HsSplicedPat)  `mapLoc`+                              pat+                    , emptyFVs+                    ) }+              -- Wrap the result of the quasi-quoter in parens so that we don't+              -- lose the outermost location set by runQuasiQuote (#7918)++----------------------+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)+rnSpliceDecl (SpliceDecl _ (L loc splice) flg)+  = rnSpliceGen run_decl_splice pend_decl_splice splice+  where+    pend_decl_splice rn_splice+       = ( makePending UntypedDeclSplice rn_splice+         , SpliceDecl noExtField (L loc rn_splice) flg)++    run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (ppr rn_splice)+rnSpliceDecl (XSpliceDecl nec) = noExtCon nec++rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)+-- Declaration splice at the very top level of the module+rnTopSpliceDecls splice+   = do  { (rn_splice, fvs) <- checkNoErrs $+                               setStage (Splice Untyped) $+                               rnSplice splice+           -- As always, be sure to checkNoErrs above lest we end up with+           -- holes making it to typechecking, hence #12584.+           --+           -- Note that we cannot call checkNoErrs for the whole duration+           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes+           -- the local environment to temporarily contain a new+           -- reference to store errors, and add_mod_finalizers would+           -- cause this reference to be stored after checkNoErrs finishes.+           -- This is checked by test TH_finalizer.+         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty+         ; (decls, mod_finalizers) <- checkNoErrs $+               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice+         ; add_mod_finalizers_now mod_finalizers+         ; return (decls,fvs) }+   where+     ppr_decls :: [LHsDecl GhcPs] -> SDoc+     ppr_decls ds = vcat (map ppr ds)++     -- Adds finalizers to the global environment instead of delaying them+     -- to the type checker.+     --+     -- Declaration splices do not have an interesting local environment so+     -- there is no point in delaying them.+     --+     -- See Note [Delaying modFinalizers in untyped splices].+     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()+     add_mod_finalizers_now []             = return ()+     add_mod_finalizers_now mod_finalizers = do+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+       env <- getLclEnv+       updTcRef th_modfinalizers_var $ \fins ->+         (env, ThModFinalizers mod_finalizers) : fins+++{-+Note [rnSplicePat]+~~~~~~~~~~~~~~~~~~+Renaming a pattern splice is a bit tricky, because we need the variables+bound in the pattern to be in scope in the RHS of the pattern. This scope+management is effectively done by using continuation-passing style in+GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here+(it would create import cycles and generally conflict with renaming other+splices), so we really want to return a (Pat RdrName) -- the result of+running the splice -- which can then be further renamed in GHC.Rename.Pat, in+the CpsRn monad.++The problem is that if we're renaming a splice within a bracket, we+*don't* want to run the splice now. We really do just want to rename+it to an HsSplice Name. Of course, then we can't know what variables+are bound within the splice. So we accept any unbound variables and+rename them again when the bracket is spliced in.  If a variable is brought+into scope by a pattern splice all is fine.  If it is not then an error is+reported.++In any case, when we're done in rnSplicePat, we'll either have a+Pat RdrName (the result of running a top-level splice) or a Pat Name+(the renamed nested splice). Thus, the awkward return type of+rnSplicePat.+-}++spliceCtxt :: HsSplice GhcPs -> SDoc+spliceCtxt splice+  = hang (text "In the" <+> what) 2 (ppr splice)+  where+    what = case splice of+             HsUntypedSplice {} -> text "untyped splice:"+             HsTypedSplice   {} -> text "typed splice:"+             HsQuasiQuote    {} -> text "quasi-quotation:"+             HsSpliced       {} -> text "spliced expression:"+             HsSplicedT      {} -> text "spliced expression:"+             XSplice         {} -> text "spliced expression:"++-- | The splice data to be logged+data SpliceInfo+  = SpliceInfo+    { spliceDescription  :: String+    , spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls+                                                  --        added by addTopDecls+    , spliceIsDecl       :: Bool    -- True <=> put the generate code in a file+                                    --          when -dth-dec-file is on+    , spliceGenerated    :: SDoc+    }+        -- Note that 'spliceSource' is *renamed* but not *typechecked*+        -- Reason (a) less typechecking crap+        --        (b) data constructors after type checking have been+        --            changed to their *wrappers*, and that makes them+        --            print always fully qualified++-- | outputs splice information for 2 flags which have different output formats:+-- `-ddump-splices` and `-dth-dec-file`+traceSplice :: SpliceInfo -> TcM ()+traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src+                        , spliceGenerated = gen, spliceIsDecl = is_decl })+  = do { loc <- case mb_src of+                   Nothing        -> getSrcSpanM+                   Just (L loc _) -> return loc+       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)++       ; when is_decl $  -- Raw material for -dth-dec-file+         do { dflags <- getDynFlags+            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file+                                             "" FormatHaskell (spliceCodeDoc loc) } }+  where+    -- `-ddump-splices`+    spliceDebugDoc :: SrcSpan -> SDoc+    spliceDebugDoc loc+      = let code = case mb_src of+                     Nothing -> ending+                     Just e  -> nest 2 (ppr (stripParensHsExpr e)) : ending+            ending = [ text "======>", nest 2 gen ]+        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)+               2 (sep code)++    -- `-dth-dec-file`+    spliceCodeDoc :: SrcSpan -> SDoc+    spliceCodeDoc loc+      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd+             , gen ]++illegalTypedSplice :: SDoc+illegalTypedSplice = text "Typed splices may not appear in untyped brackets"++illegalUntypedSplice :: SDoc+illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"++checkThLocalName :: Name -> RnM ()+checkThLocalName name+  | isUnboundName name   -- Do not report two errors for+  = return ()            --   $(not_in_scope args)++  | otherwise+  = do  { traceRn "checkThLocalName" (ppr name)+        ; mb_local_use <- getStageAndBindLevel name+        ; case mb_local_use of {+             Nothing -> return () ;  -- Not a locally-bound thing+             Just (top_lvl, bind_lvl, use_stage) ->+    do  { let use_lvl = thLevel use_stage+        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl+                                               <+> ppr use_stage+                                               <+> ppr use_lvl)+        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }++--------------------------------------+checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel+                       -> Name -> TcM ()+-- We are inside brackets, and (use_lvl > bind_lvl)+-- Now we must check whether there's a cross-stage lift to do+-- Examples   \x -> [| x |]+--            [| map |]+--+-- This code is similar to checkCrossStageLifting in TcExpr, but+-- this is only run on *untyped* brackets.++checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name+  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets+  , use_lvl > bind_lvl                               -- Cross-stage condition+  = check_cross_stage_lifting top_lvl name ps_var+  | otherwise+  = return ()++check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()+check_cross_stage_lifting top_lvl name ps_var+  | isTopLevel top_lvl+        -- Top-level identifiers in this module,+        -- (which have External Names)+        -- are just like the imported case:+        -- no need for the 'lifting' treatment+        -- E.g.  this is fine:+        --   f x = x+        --   g y = [| f 3 |]+  = when (isExternalName name) (keepAlive name)+    -- See Note [Keeping things alive for Template Haskell]++  | otherwise+  =     -- Nested identifiers, such as 'x' in+        -- E.g. \x -> [| h x |]+        -- We must behave as if the reference to x was+        --      h $(lift x)+        -- We use 'x' itself as the SplicePointName, used by+        -- the desugarer to stitch it all back together.+        -- If 'x' occurs many times we may get many identical+        -- bindings of the same SplicePointName, but that doesn't+        -- matter, although it's a mite untidy.+    do  { traceRn "checkCrossStageLifting" (ppr name)++          -- Construct the (lift x) expression+        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)+              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr++          -- Update the pending splices+        ; ps <- readMutVar ps_var+        ; writeMutVar ps_var (pend_splice : ps) }++{-+Note [Keeping things alive for Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = x+1+  g y = [| f 3 |]++Here 'f' is referred to from inside the bracket, which turns into data+and mentions only f's *name*, not 'f' itself. So we need some other+way to keep 'f' alive, lest it get dropped as dead code.  That's what+keepAlive does. It puts it in the keep-alive set, which subsequently+ensures that 'f' stays as a top level binding.++This must be done by the renamer, not the type checker (as of old),+because the type checker doesn't typecheck the body of untyped+brackets (#8540).++A thing can have a bind_lvl of outerLevel, but have an internal name:+   foo = [d| op = 3+             bop = op + 1 |]+Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is+bound inside a bracket.  That is because we don't even even record+binding levels for top-level things; the binding levels are in the+LocalRdrEnv.++So the occurrence of 'op' in the rhs of 'bop' looks a bit like a+cross-stage thing, but it isn't really.  And in fact we never need+to do anything here for top-level bound things, so all is fine, if+a bit hacky.++For these chaps (which have Internal Names) we don't want to put+them in the keep-alive set.++Note [Quoting names]+~~~~~~~~~~~~~~~~~~~~+A quoted name 'n is a bit like a quoted expression [| n |], except that we+have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing+the use-level to account for the brackets, the cases are:++        bind > use                      Error+        bind = use+1                    OK+        bind < use+                Imported things         OK+                Top-level things        OK+                Non-top-level           Error++where 'use' is the binding level of the 'n quote. (So inside the implied+bracket the level would be use+1.)++Examples:++  f 'map        -- OK; also for top-level defns of this module++  \x. f 'x      -- Not ok (bind = 1, use = 1)+                -- (whereas \x. f [| x |] might have been ok, by+                --                               cross-stage lifting++  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)++  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)+-}
+ compiler/GHC/Rename/Splice.hs-boot view
@@ -0,0 +1,14 @@+module GHC.Rename.Splice where++import GhcPrelude+import GHC.Hs+import TcRnMonad+import NameSet+++rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)+rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)+                                          , FreeVars )+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)++rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
+ compiler/GHC/Rename/Types.hs view
@@ -0,0 +1,1783 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module GHC.Rename.Types (+        -- Type related stuff+        rnHsType, rnLHsType, rnLHsTypes, rnContext,+        rnHsKind, rnLHsKind, rnLHsTypeArgs,+        rnHsSigType, rnHsWcType,+        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,+        newTyVarNameRn,+        rnConDeclFields,+        rnLTyVar,++        -- Precence related stuff+        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,+        checkPrecMatch, checkSectionPrec,++        -- Binding related stuff+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,+        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,+        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,+        extractHsTysRdrTyVarsDups,+        extractRdrKindSigVars, extractDataDefnKindVars,+        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,+        nubL, elemRdr+  ) where++import GhcPrelude++import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType )++import DynFlags+import GHC.Hs+import GHC.Rename.Doc    ( rnLHsDoc, rnMbLHsDoc )+import GHC.Rename.Env+import GHC.Rename.Utils  ( HsDocContext(..), withHsDocContext, mapFvRn+                         , pprHsDocContext, bindLocalNamesFV, typeAppErr+                         , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )+import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn+                         , lookupTyFixityRn )+import TcRnMonad+import RdrName+import PrelNames+import TysPrim          ( funTyConName )+import Name+import SrcLoc+import NameSet+import FieldLabel++import Util+import ListSetOps       ( deleteBys )+import BasicTypes       ( compareFixity, funTyFixity, negateFixity+                        , Fixity(..), FixityDirection(..), LexicalFixity(..)+                        , TypeOrKind(..) )+import Outputable+import FastString+import Maybes+import qualified GHC.LanguageExtensions as LangExt++import Data.List          ( nubBy, partition, (\\) )+import Control.Monad      ( unless, when )++#include "HsVersions.h"++{-+These type renamers are in a separate module, rather than in (say) GHC.Rename.Source,+to break several loop.++*********************************************************+*                                                       *+           HsSigWcType (i.e with wildcards)+*                                                       *+*********************************************************+-}++data HsSigWcTypeScoping = AlwaysBind+                          -- ^ Always bind any free tyvars of the given type,+                          --   regardless of whether we have a forall at the top+                        | BindUnlessForall+                          -- ^ Unless there's forall at the top, do the same+                          --   thing as 'AlwaysBind'+                        | NeverBind+                          -- ^ Never bind any free tyvars++rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs+              -> RnM (LHsSigWcType GhcRn, FreeVars)+rnHsSigWcType scoping doc sig_ty+  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->+    return (sig_ty', emptyFVs)++rnHsSigWcTypeScoped :: HsSigWcTypeScoping+                       -- AlwaysBind: for pattern type sigs and rules we /do/ want+                       --             to bring those type variables into scope, even+                       --             if there's a forall at the top which usually+                       --             stops that happening+                       -- e.g  \ (x :: forall a. a-> b) -> e+                       -- Here we do bring 'b' into scope+                    -> HsDocContext -> LHsSigWcType GhcPs+                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))+                    -> RnM (a, FreeVars)+-- Used for+--   - Signatures on binders in a RULE+--   - Pattern type signatures+-- Wildcards are allowed+-- type signatures on binders only allowed with ScopedTypeVariables+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside+  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables+       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)+       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside+       }++rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs+                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+-- rn_hs_sig_wc_type is used for source-language type signatures+rn_hs_sig_wc_type scoping ctxt+                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})+                  thing_inside+  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty+       ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars+       ; let nwc_rdrs = nubL nwc_rdrs'+             bind_free_tvs = case scoping of+                               AlwaysBind       -> True+                               BindUnlessForall -> not (isLHsForAllTy hs_ty)+                               NeverBind        -> False+       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->+    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }+             ib_ty'  = HsIB { hsib_ext = vars+                            , hsib_body = hs_ty' }+       ; (res, fvs2) <- thing_inside sig_ty'+       ; return (res, fvs1 `plusFV` fvs2) } }+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _+  = noExtCon nec+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _+  = noExtCon nec++rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)+rnHsWcType ctxt (HsWC { hswc_body = hs_ty })+  = do { free_vars <- extractFilteredRdrTyVars hs_ty+       ; (nwc_rdrs, _) <- partition_nwcs free_vars+       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }+       ; return (sig_ty', fvs) }+rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec++rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs+         -> RnM ([Name], LHsType GhcRn, FreeVars)+rnWcBody ctxt nwc_rdrs hs_ty+  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs+       ; let env = RTKE { rtke_level = TypeLevel+                        , rtke_what  = RnTypeBody+                        , rtke_nwcs  = mkNameSet nwcs+                        , rtke_ctxt  = ctxt }+       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $+                          rn_lty env hs_ty+       ; return (nwcs, hs_ty', fvs) }+  where+    rn_lty env (L loc hs_ty)+      = setSrcSpan loc $+        do { (hs_ty', fvs) <- rn_ty env hs_ty+           ; return (L loc hs_ty', fvs) }++    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)+    -- A lot of faff just to allow the extra-constraints wildcard to appear+    rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs+                                , hst_body = hs_body })+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->+        do { (hs_body', fvs) <- rn_lty env hs_body+           ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField+                                , hst_bndrs = tvs', hst_body = hs_body' }+                    , fvs) }++    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt+                        , hst_body = hs_ty })+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last+      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1+           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1+           ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]+           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_xqual = noExtField+                              , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }+                    , fvs1 `plusFV` fvs2) }++      | otherwise+      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt+           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_xqual = noExtField+                              , hst_ctxt = L cx hs_ctxt'+                              , hst_body = hs_ty' }+                    , fvs1 `plusFV` fvs2) }++    rn_ty env hs_ty = rnHsTyKi env hs_ty++    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })+++checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()+-- Rename the extra-constraint spot in a type signature+--    (blah, _) => type+-- Check that extra-constraints are allowed at all, and+-- if so that it's an anonymous wildcard+checkExtraConstraintWildCard env hs_ctxt+  = checkWildCard env mb_bad+  where+    mb_bad | not (extraConstraintWildCardsAllowed env)+           = Just base_msg+             -- Currently, we do not allow wildcards in their full glory in+             -- standalone deriving declarations. We only allow a single+             -- extra-constraints wildcard à la:+             --+             --   deriving instance _ => Eq (Foo a)+             --+             -- i.e., we don't support things like+             --+             --   deriving instance (Eq a, _) => Eq (Foo a)+           | DerivDeclCtx {} <- rtke_ctxt env+           , not (null hs_ctxt)+           = Just deriv_decl_msg+           | otherwise+           = Nothing++    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard+                   <+> text "not allowed"++    deriv_decl_msg+      = hang base_msg+           2 (vcat [ text "except as the sole constraint"+                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])++extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool+extraConstraintWildCardsAllowed env+  = case rtke_ctxt env of+      TypeSigCtx {}       -> True+      ExprWithTySigCtx {} -> True+      DerivDeclCtx {}     -> True+      StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls+      _                   -> False++-- | Finds free type and kind variables in a type,+--     without duplicates, and+--     without variables that are already in scope in LocalRdrEnv+--   NB: this includes named wildcards, which look like perfectly+--       ordinary type variables at this point+extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups+extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty)++-- | Finds free type and kind variables in a type,+--     with duplicates, but+--     without variables that are already in scope in LocalRdrEnv+--   NB: this includes named wildcards, which look like perfectly+--       ordinary type variables at this point+extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups+extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)++-- | When the NamedWildCards extension is enabled, partition_nwcs+-- removes type variables that start with an underscore from the+-- FreeKiTyVars in the argument and returns them in a separate list.+-- When the extension is disabled, the function returns the argument+-- and empty list.  See Note [Renaming named wild cards]+partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)+partition_nwcs free_vars+  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards+       ; return $+           if wildcards_enabled+           then partition is_wildcard free_vars+           else ([], free_vars) }+  where+     is_wildcard :: Located RdrName -> Bool+     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))++{- Note [Renaming named wild cards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Identifiers starting with an underscore are always parsed as type variables.+It is only here in the renamer that we give the special treatment.+See Note [The wildcard story for types] in GHC.Hs.Types.++It's easy!  When we collect the implicitly bound type variables, ready+to bring them into scope, and NamedWildCards is on, we partition the+variables into the ones that start with an underscore (the named+wildcards) and the rest. Then we just add them to the hswc_wcs field+of the HsWildCardBndrs structure, and we are done.+++*********************************************************+*                                                       *+           HsSigtype (i.e. no wildcards)+*                                                       *+****************************************************** -}++rnHsSigType :: HsDocContext+            -> TypeOrKind+            -> LHsSigType GhcPs+            -> RnM (LHsSigType GhcRn, FreeVars)+-- Used for source-language type signatures+-- that cannot have wildcards+rnHsSigType ctx level (HsIB { hsib_body = hs_ty })+  = do { traceRn "rnHsSigType" (ppr hs_ty)+       ; vars <- extractFilteredRdrTyVarsDups hs_ty+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->+    do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty++       ; return ( HsIB { hsib_ext = vars+                       , hsib_body = body' }+                , fvs ) } }+rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec++rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables+                           -- E.g.  f :: forall a. a->b+                           --  we do not want to bring 'b' into scope, hence False+                           -- But   f :: a -> b+                           --  we want to bring both 'a' and 'b' into scope+                -> FreeKiTyVarsWithDups+                                   -- Free vars of hs_ty (excluding wildcards)+                                   -- May have duplicates, which is+                                   -- checked here+                -> ([Name] -> RnM (a, FreeVars))+                -> RnM (a, FreeVars)+rnImplicitBndrs bind_free_tvs+                fvs_with_dups+                thing_inside+  = do { let fvs = nubL fvs_with_dups+             real_fvs | bind_free_tvs = fvs+                      | otherwise     = []++       ; traceRn "rnImplicitBndrs" $+         vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ]++       ; loc <- getSrcSpanM+       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs++       ; bindLocalNamesFV vars $+         thing_inside vars }++{- ******************************************************+*                                                       *+           LHsType and HsType+*                                                       *+****************************************************** -}++{-+rnHsType is here because we call it from loadInstDecl, and I didn't+want a gratuitous knot.++Note [Context quantification]+-----------------------------+Variables in type signatures are implicitly quantified+when (1) they are in a type signature not beginning+with "forall" or (2) in any qualified type T => R.+We are phasing out (2) since it leads to inconsistencies+(#4426):++data A = A (a -> a)           is an error+data A = A (Eq a => a -> a)   binds "a"+data A = A (Eq a => a -> b)   binds "a" and "b"+data A = A (() => a -> b)     binds "a" and "b"+f :: forall a. a -> b         is an error+f :: forall a. () => a -> b   is an error+f :: forall a. a -> (() => b) binds "a" and "b"++This situation is now considered to be an error. See rnHsTyKi for case+HsForAllTy Qualified.++Note [QualTy in kinds]+~~~~~~~~~~~~~~~~~~~~~~+I was wondering whether QualTy could occur only at TypeLevel.  But no,+we can have a qualified type in a kind too. Here is an example:++  type family F a where+    F Bool = Nat+    F Nat  = Type++  type family G a where+    G Type = Type -> Type+    G ()   = Nat++  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where+    MkX :: X 'True '()++See that k1 becomes Bool and k2 becomes (), so the equality is+satisfied. If I write MkX :: X 'True 'False, compilation fails with a+suitable message:++  MkX :: X 'True '()+    • Couldn't match kind ‘G Bool’ with ‘Nat’+      Expected kind: G Bool+        Actual kind: F Bool++However: in a kind, the constraints in the QualTy must all be+equalities; or at least, any kinds with a class constraint are+uninhabited.+-}++data RnTyKiEnv+  = RTKE { rtke_ctxt  :: HsDocContext+         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?+         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?+         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards+    }++data RnTyKiWhat = RnTypeBody+                | RnTopConstraint   -- Top-level context of HsSigWcTypes+                | RnConstraint      -- All other constraints++instance Outputable RnTyKiEnv where+  ppr (RTKE { rtke_level = lev, rtke_what = what+            , rtke_nwcs = wcs, rtke_ctxt = ctxt })+    = text "RTKE"+      <+> braces (sep [ ppr lev, ppr what, ppr wcs+                      , pprHsDocContext ctxt ])++instance Outputable RnTyKiWhat where+  ppr RnTypeBody      = text "RnTypeBody"+  ppr RnTopConstraint = text "RnTopConstraint"+  ppr RnConstraint    = text "RnConstraint"++mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv+mkTyKiEnv cxt level what+ = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet+        , rtke_what = what, rtke_ctxt = cxt }++isRnKindLevel :: RnTyKiEnv -> Bool+isRnKindLevel (RTKE { rtke_level = KindLevel }) = True+isRnKindLevel _                                 = False++--------------+rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)+rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty++rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys++rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)+rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty++rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)+rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind++rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)+rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind++-- renaming a type only, not a kind+rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs+                -> RnM (LHsTypeArg GhcRn, FreeVars)+rnLHsTypeArg ctxt (HsValArg ty)+   = do { (tys_rn, fvs) <- rnLHsType ctxt ty+        ; return (HsValArg tys_rn, fvs) }+rnLHsTypeArg ctxt (HsTypeArg l ki)+   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki+        ; return (HsTypeArg l kis_rn, fvs) }+rnLHsTypeArg _ (HsArgPar sp)+   = return (HsArgPar sp, emptyFVs)++rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]+                 -> RnM ([LHsTypeArg GhcRn], FreeVars)+rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args++--------------+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs+              -> RnM (LHsContext GhcRn, FreeVars)+rnTyKiContext env (L loc cxt)+  = do { traceRn "rncontext" (ppr cxt)+       ; let env' = env { rtke_what = RnConstraint }+       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt+       ; return (L loc cxt', fvs) }++rnContext :: HsDocContext -> LHsContext GhcPs+          -> RnM (LHsContext GhcRn, FreeVars)+rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta++--------------+rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)+rnLHsTyKi env (L loc ty)+  = setSrcSpan loc $+    do { (ty', fvs) <- rnHsTyKi env ty+       ; return (L loc ty', fvs) }++rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)++rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars+                            , hst_body = tau })+  = do { checkPolyKinds env ty+       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)+                           Nothing tyvars $ \ tyvars' ->+    do { (tau',  fvs) <- rnLHsTyKi env tau+       ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField+                             , hst_bndrs = tyvars' , hst_body =  tau' }+                , fvs) } }++rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })+  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]+       ; (ctxt', fvs1) <- rnTyKiContext env lctxt+       ; (tau',  fvs2) <- rnLHsTyKi env tau+       ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'+                          , hst_body =  tau' }+                , fvs1 `plusFV` fvs2) }++rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))+  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $+         unlessXOptM LangExt.PolyKinds $ addErr $+         withHsDocContext (rtke_ctxt env) $+         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)+              , text "Perhaps you intended to use PolyKinds" ]+           -- Any type variable at the kind level is illegal without the use+           -- of PolyKinds (see #14710)+       ; name <- rnTyVar env rdr_name+       ; return (HsTyVar noExtField ip (L loc name), unitFV name) }++rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)+  = setSrcSpan (getLoc l_op) $+    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op+        ; fix   <- lookupTyFixityRn l_op'+        ; (ty1', fvs2) <- rnLHsTyKi env ty1+        ; (ty2', fvs3) <- rnLHsTyKi env ty2+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2)+                               (unLoc l_op') fix ty1' ty2'+        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }++rnHsTyKi env (HsParTy _ ty)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsParTy noExtField ty', fvs) }++rnHsTyKi env (HsBangTy _ b ty)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsBangTy noExtField b ty', fvs) }++rnHsTyKi env ty@(HsRecTy _ flds)+  = do { let ctxt = rtke_ctxt env+       ; fls          <- get_fields ctxt+       ; (flds', fvs) <- rnConDeclFields ctxt fls flds+       ; return (HsRecTy noExtField flds', fvs) }+  where+    get_fields (ConDeclCtx names)+      = concatMapM (lookupConstructorFields . unLoc) names+    get_fields _+      = do { addErr (hang (text "Record syntax is illegal here:")+                                   2 (ppr ty))+           ; return [] }++rnHsTyKi env (HsFunTy _ ty1 ty2)+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1+        -- Might find a for-all as the arg of a function type+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+        -- Or as the result.  This happens when reading Prelude.hi+        -- when we find return :: forall m. Monad m -> forall a. a -> m a++        -- Check for fixity rearrangements+       ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2'+       ; return (res_ty, fvs1 `plusFV` fvs2) }++rnHsTyKi env listTy@(HsListTy _ ty)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env listTy))+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsListTy noExtField ty', fvs) }++rnHsTyKi env t@(HsKindSig _ ty k)+  = do { checkPolyKinds env t+       ; kind_sigs_ok <- xoptM LangExt.KindSignatures+       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)+       ; (ty', lhs_fvs) <- rnLHsTyKi env ty+       ; (k', sig_fvs)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k+       ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }++-- Unboxed tuples are allowed to have poly-typed arguments.  These+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env tupleTy))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsTupleTy noExtField tup_con tys', fvs) }++rnHsTyKi env sumTy@(HsSumTy _ tys)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env sumTy))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsSumTy noExtField tys', fvs) }++-- Ensure that a type-level integer is nonnegative (#8306, #8412)+rnHsTyKi env tyLit@(HsTyLit _ t)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env tyLit))+       ; when (negLit t) (addErr negLitErr)+       ; checkPolyKinds env tyLit+       ; return (HsTyLit noExtField t, emptyFVs) }+  where+    negLit (HsStrTy _ _) = False+    negLit (HsNumTy _ i) = i < 0+    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit++rnHsTyKi env (HsAppTy _ ty1 ty2)+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+       ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }++rnHsTyKi env (HsAppKindTy l ty k)+  = do { kind_app <- xoptM LangExt.TypeApplications+       ; unless kind_app (addErr (typeAppErr "kind" k))+       ; (ty', fvs1) <- rnLHsTyKi env ty+       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k+       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }++rnHsTyKi env t@(HsIParamTy _ n ty)+  = do { notInKinds env t+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsIParamTy noExtField n ty', fvs) }++rnHsTyKi _ (HsStarTy _ isUni)+  = return (HsStarTy noExtField isUni, emptyFVs)++rnHsTyKi _ (HsSpliceTy _ sp)+  = rnSpliceType sp++rnHsTyKi env (HsDocTy _ ty haddock_doc)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; haddock_doc' <- rnLHsDoc haddock_doc+       ; return (HsDocTy noExtField ty' haddock_doc', fvs) }++rnHsTyKi _ (XHsType (NHsCoreTy ty))+  = return (XHsType (NHsCoreTy ty), emptyFVs)+    -- The emptyFVs probably isn't quite right+    -- but I don't think it matters++rnHsTyKi env ty@(HsExplicitListTy _ ip tys)+  = do { checkPolyKinds env ty+       ; data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env ty))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsExplicitListTy noExtField ip tys', fvs) }++rnHsTyKi env ty@(HsExplicitTupleTy _ tys)+  = do { checkPolyKinds env ty+       ; data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env ty))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsExplicitTupleTy noExtField tys', fvs) }++rnHsTyKi env (HsWildCardTy _)+  = do { checkAnonWildCard env+       ; return (HsWildCardTy noExtField, emptyFVs) }++--------------+rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name+rnTyVar env rdr_name+  = do { name <- lookupTypeOccRn rdr_name+       ; checkNamedWildCard env name+       ; return name }++rnLTyVar :: Located RdrName -> RnM (Located Name)+-- Called externally; does not deal with wildcards+rnLTyVar (L loc rdr_name)+  = do { tyvar <- lookupTypeOccRn rdr_name+       ; return (L loc tyvar) }++--------------+rnHsTyOp :: Outputable a+         => RnTyKiEnv -> a -> Located RdrName+         -> RnM (Located Name, FreeVars)+rnHsTyOp env overall_ty (L loc op)+  = do { ops_ok <- xoptM LangExt.TypeOperators+       ; op' <- rnTyVar env op+       ; unless (ops_ok || op' `hasKey` eqTyConKey) $+           addErr (opTyErr op overall_ty)+       ; let l_op' = L loc op'+       ; return (l_op', unitFV op') }++--------------+notAllowed :: SDoc -> SDoc+notAllowed doc+  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")++checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()+checkWildCard env (Just doc)+  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]+checkWildCard _ Nothing+  = return ()++checkAnonWildCard :: RnTyKiEnv -> RnM ()+-- Report an error if an anonymous wildcard is illegal here+checkAnonWildCard env+  = checkWildCard env mb_bad+  where+    mb_bad :: Maybe SDoc+    mb_bad | not (wildCardsAllowed env)+           = Just (notAllowed pprAnonWildCard)+           | otherwise+           = case rtke_what env of+               RnTypeBody      -> Nothing+               RnTopConstraint -> Just constraint_msg+               RnConstraint    -> Just constraint_msg++    constraint_msg = hang+                         (notAllowed pprAnonWildCard <+> text "in a constraint")+                        2 hint_msg+    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"+                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]++checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()+-- Report an error if a named wildcard is illegal here+checkNamedWildCard env name+  = checkWildCard env mb_bad+  where+    mb_bad | not (name `elemNameSet` rtke_nwcs env)+           = Nothing  -- Not a wildcard+           | not (wildCardsAllowed env)+           = Just (notAllowed (ppr name))+           | otherwise+           = case rtke_what env of+               RnTypeBody      -> Nothing   -- Allowed+               RnTopConstraint -> Nothing   -- Allowed; e.g.+                  -- f :: (Eq _a) => _a -> Int+                  -- g :: (_a, _b) => T _a _b -> Int+                  -- The named tyvars get filled in from elsewhere+               RnConstraint    -> Just constraint_msg+    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"++wildCardsAllowed :: RnTyKiEnv -> Bool+-- ^ In what contexts are wildcards permitted+wildCardsAllowed env+   = case rtke_ctxt env of+       TypeSigCtx {}       -> True+       TypBrCtx {}         -> True   -- Template Haskell quoted type+       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice+       ExprWithTySigCtx {} -> True+       PatCtx {}           -> True+       RuleCtx {}          -> True+       FamPatCtx {}        -> True   -- Not named wildcards though+       GHCiCtx {}          -> True+       HsTypeCtx {}        -> True+       StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls+       _                   -> False++++---------------+-- | Ensures either that we're in a type or that -XPolyKinds is set+checkPolyKinds :: Outputable ty+                => RnTyKiEnv+                -> ty      -- ^ type+                -> RnM ()+checkPolyKinds env ty+  | isRnKindLevel env+  = do { polykinds <- xoptM LangExt.PolyKinds+       ; unless polykinds $+         addErr (text "Illegal kind:" <+> ppr ty $$+                 text "Did you mean to enable PolyKinds?") }+checkPolyKinds _ _ = return ()++notInKinds :: Outputable ty+           => RnTyKiEnv+           -> ty+           -> RnM ()+notInKinds env ty+  | isRnKindLevel env+  = addErr (text "Illegal kind:" <+> ppr ty)+notInKinds _ _ = return ()++{- *****************************************************+*                                                      *+          Binding type variables+*                                                      *+***************************************************** -}++bindSigTyVarsFV :: [Name]+                -> RnM (a, FreeVars)+                -> RnM (a, FreeVars)+-- Used just before renaming the defn of a function+-- with a separate type signature, to bring its tyvars into scope+-- With no -XScopedTypeVariables, this is a no-op+bindSigTyVarsFV tvs thing_inside+  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables+        ; if not scoped_tyvars then+                thing_inside+          else+                bindLocalNamesFV tvs thing_inside }++-- | Simply bring a bunch of RdrNames into scope. No checking for+-- validity, at all. The binding location is taken from the location+-- on each name.+bindLRdrNames :: [Located RdrName]+              -> ([Name] -> RnM (a, FreeVars))+              -> RnM (a, FreeVars)+bindLRdrNames rdrs thing_inside+  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs+       ; bindLocalNamesFV var_names $+         thing_inside var_names }++---------------+bindHsQTyVars :: forall a b.+                 HsDocContext+              -> Maybe SDoc         -- Just d => check for unused tvs+                                    --   d is a phrase like "in the type ..."+              -> Maybe a            -- Just _  => an associated type decl+              -> [Located RdrName]  -- Kind variables from scope, no dups+              -> (LHsQTyVars GhcPs)+              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))+                  -- The Bool is True <=> all kind variables used in the+                  -- kind signature are bound on the left.  Reason:+                  -- the last clause of Note [CUSKs: Complete user-supplied+                  -- kind signatures] in GHC.Hs.Decls+              -> RnM (b, FreeVars)++-- See Note [bindHsQTyVars examples]+-- (a) Bring kind variables into scope+--     both (i)  passed in body_kv_occs+--     and  (ii) mentioned in the kinds of hsq_bndrs+-- (b) Bring type variables into scope+--+bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside+  = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs+             bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs++       ; let -- See Note [bindHsQTyVars examples] for what+             -- all these various things are doing+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]+             bndrs        = map hsLTyVarLocName hs_tv_bndrs+             kv_occs      = nubL (bndr_kv_occs ++ body_kv_occs)+                                 -- Make sure to list the binder kvs before the+                                 -- body kvs, as mandated by+                                 -- Note [Ordering of implicit variables]+             implicit_kvs = filter_occs bndrs kv_occs+             del          = deleteBys eqLocated+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)++       ; traceRn "checkMixedVars3" $+           vcat [ text "kv_occs" <+> ppr kv_occs+                , text "bndrs"   <+> ppr hs_tv_bndrs+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)+                ]++       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs++       ; bindLocalNamesFV implicit_kv_nms                     $+         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->+    do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)+       ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms+                              , hsq_explicit  = rn_bndrs })+                      all_bound_on_lhs } }++  where+    filter_occs :: [Located RdrName]   -- Bound here+                -> [Located RdrName]   -- Potential implicit binders+                -> [Located RdrName]   -- Final implicit binders+    -- Filter out any potential implicit binders that are either+    -- already in scope, or are explicitly bound in the same HsQTyVars+    filter_occs bndrs occs+      = filterOut is_in_scope occs+      where+        is_in_scope locc = locc `elemRdr` bndrs++{- Note [bindHsQTyVars examples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   data T k (a::k1) (b::k) :: k2 -> k1 -> *++Then:+  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables+  bndrs       = [k,a,b]++  bndr_kv_occs = [k,k1], kind variables free in kind signatures+                         of hs_tv_bndrs++  body_kv_occs = [k2,k1], kind variables free in the+                          result kind signature++  implicit_kvs = [k1,k2], kind variables free in kind signatures+                          of hs_tv_bndrs, and not bound by bndrs++* We want to quantify add implicit bindings for implicit_kvs++* If implicit_body_kvs is non-empty, then there is a kind variable+  mentioned in the kind signature that is not bound "on the left".+  That's one of the rules for a CUSK, so we pass that info on+  as the second argument to thing_inside.++* Order is not important in these lists.  All we are doing is+  bring Names into scope.++Finally, you may wonder why filter_occs removes in-scope variables+from bndr/body_kv_occs.  How can anything be in scope?  Answer:+HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax+ConDecls+   data T a = forall (b::k). MkT a b+The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire+ConDecl.  Hence the local RdrEnv may be non-empty and we must filter+out 'a' from the free vars.  (Mind you, in this situation all the+implicit kind variables are bound at the data type level, so there+are none to bind in the ConDecl, so there are no implicitly bound+variables at all.++Note [Kind variable scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+  data T (a :: k) k = ...+we report "k is out of scope" for (a::k).  Reason: k is not brought+into scope until the explicit k-binding that follows.  It would be+terribly confusing to bring into scope an /implicit/ k for a's kind+and a distinct, shadowing explicit k that follows, something like+  data T {k1} (a :: k1) k = ...++So the rule is:++   the implicit binders never include any+   of the explicit binders in the group++Note that in the denerate case+  data T (a :: a) = blah+we get a complaint the second 'a' is not in scope.++That applies to foralls too: e.g.+   forall (a :: k) k . blah++But if the foralls are split, we treat the two groups separately:+   forall (a :: k). forall k. blah+Here we bring into scope an implicit k, which is later shadowed+by the explicit k.++In implementation terms++* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete+  the binders {a,k}, and so end with no implicit binders.  Then we+  rename the binders left-to-right, and hence see that 'k' is out of+  scope in the kind of 'a'.++* Similarly in extract_hs_tv_bndrs++Note [Variables used as both types and kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We bind the type variables tvs, and kvs is the set of free variables of the+kinds in the scope of the binding. Here is one typical example:++   forall a b. a -> (b::k) -> (c::a)++Here, tvs will be {a,b}, and kvs {k,a}.++We must make sure that kvs includes all of variables in the kinds of type+variable bindings. For instance:++   forall k (a :: k). Proxy a++If we only look in the body of the `forall` type, we will mistakenly conclude+that kvs is {}. But in fact, the type variable `k` is also used as a kind+variable in (a :: k), later in the binding. (This mistake lead to #14710.)+So tvs is {k,a} and kvs is {k}.++NB: we do this only at the binding site of 'tvs'.+-}++bindLHsTyVarBndrs :: HsDocContext+                  -> Maybe SDoc            -- Just d => check for unused tvs+                                           --   d is a phrase like "in the type ..."+                  -> Maybe a               -- Just _  => an associated type decl+                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars+                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))+                  -> RnM (b, FreeVars)+bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside+  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)+       ; checkDupRdrNames tv_names_w_loc+       ; go tv_bndrs thing_inside }+  where+    tv_names_w_loc = map hsLTyVarLocName tv_bndrs++    go []     thing_inside = thing_inside []+    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->+                             do { (res, fvs) <- go bs $ \ bs' ->+                                                thing_inside (b' : bs')+                                ; warn_unused b' fvs+                                ; return (res, fvs) }++    warn_unused tv_bndr fvs = case mb_in_doc of+      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs+      Nothing     -> return ()++bindLHsTyVarBndr :: HsDocContext+                 -> Maybe a   -- associated class+                 -> LHsTyVarBndr GhcPs+                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))+                 -> RnM (b, FreeVars)+bindLHsTyVarBndr _doc mb_assoc (L loc+                                 (UserTyVar x+                                    lrdr@(L lv _))) thing_inside+  = do { nm <- newTyVarNameRn mb_assoc lrdr+       ; bindLocalNamesFV [nm] $+         thing_inside (L loc (UserTyVar x (L lv nm))) }++bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))+                 thing_inside+  = do { sig_ok <- xoptM LangExt.KindSignatures+           ; unless sig_ok (badKindSigErr doc kind)+           ; (kind', fvs1) <- rnLHsKind doc kind+           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr+           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]+               $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))+           ; return (b, fvs1 `plusFV` fvs2) }++bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec++newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name+newTyVarNameRn mb_assoc (L loc rdr)+  = do { rdr_env <- getLocalRdrEnv+       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of+           (Just _, Just n) -> return n+              -- Use the same Name as the parent class decl++           _                -> newLocalBndrRn (L loc rdr) }+{-+*********************************************************+*                                                       *+        ConDeclField+*                                                       *+*********************************************************++When renaming a ConDeclField, we have to find the FieldLabel+associated with each field.  But we already have all the FieldLabels+available (since they were brought into scope by+GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an+argument, build a map and look them up.+-}++rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]+                -> RnM ([LConDeclField GhcRn], FreeVars)+-- Also called from GHC.Rename.Source+-- No wildcards can appear in record fields+rnConDeclFields ctxt fls fields+   = mapFvRn (rnField fl_env env) fields+  where+    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody+    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]++rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs+        -> RnM (LConDeclField GhcRn, FreeVars)+rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))+  = do { let new_names = map (fmap lookupField) names+       ; (new_ty, fvs) <- rnLHsTyKi env ty+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc+       ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc)+                , fvs) }+  where+    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn+    lookupField (FieldOcc _ (L lr rdr)) =+        FieldOcc (flSelector fl) (L lr rdr)+      where+        lbl = occNameFS $ rdrNameOcc rdr+        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl+    lookupField (XFieldOcc nec) = noExtCon nec+rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec++{-+************************************************************************+*                                                                      *+        Fixities and precedence parsing+*                                                                      *+************************************************************************++@mkOpAppRn@ deals with operator fixities.  The argument expressions+are assumed to be already correctly arranged.  It needs the fixities+recorded in the OpApp nodes, because fixity info applies to the things+the programmer actually wrote, so you can't find it out from the Name.++Furthermore, the second argument is guaranteed not to be another+operator application.  Why? Because the parser parses all+operator applications left-associatively, EXCEPT negation, which+we need to handle specially.+Infix types are read in a *right-associative* way, so that+        a `op` b `op` c+is always read in as+        a `op` (b `op` c)++mkHsOpTyRn rearranges where necessary.  The two arguments+have already been renamed and rearranged.  It's made rather tiresome+by the presence of ->, which is a separate syntactic construct.+-}++---------------+-- Building (ty1 `op1` (ty21 `op2` ty22))+mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)+           -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+           -> RnM (HsType GhcRn)++mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22))+  = do  { fix2 <- lookupTyFixityRn op2+        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1+                      (\t1 t2 -> HsOpTy noExtField t1 op2 t2)+                      (unLoc op2) fix2 ty21 ty22 loc2 }++mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))+  = mk_hs_op_ty mk1 pp_op1 fix1 ty1+                (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2++mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment+  = return (mk1 ty1 ty2)++---------------+mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)+            -> Name -> Fixity -> LHsType GhcRn+            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)+            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan+            -> RnM (HsType GhcRn)+mk_hs_op_ty mk1 op1 fix1 ty1+            mk2 op2 fix2 ty21 ty22 loc2+  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)+                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }+  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)+                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21+                         ; return (mk2 (noLoc new_ty) ty22) }+  where+    (nofix_error, associate_right) = compareFixity fix1 fix2+++---------------------------+mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged+          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity+          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might+                                       -- be a NegApp)+          -> RnM (HsExpr GhcRn)++-- (e11 `op1` e12) `op2` e2+mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+  | nofix_error+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)+       return (OpApp fix2 e1 op2 e2)++  | associate_right = do+    new_e <- mkOpAppRn e12 op2 fix2 e2+    return (OpApp fix1 e11 op1 (L loc' new_e))+  where+    loc'= combineLocs e12 e2+    (nofix_error, associate_right) = compareFixity fix1 fix2++---------------------------+--      (- neg_arg) `op` e2+mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2+  | nofix_error+  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)+       return (OpApp fix2 e1 op2 e2)++  | associate_right+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2+       return (NegApp noExtField (L loc' new_e) neg_name)+  where+    loc' = combineLocs neg_arg e2+    (nofix_error, associate_right) = compareFixity negateFixity fix2++---------------------------+--      e1 `op` - neg_arg+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right+  | not associate_right                        -- We *want* right association+  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)+       return (OpApp fix1 e1 op1 e2)+  where+    (_, associate_right) = compareFixity fix1 negateFixity++---------------------------+--      Default case+mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment+  = ASSERT2( right_op_ok fix (unLoc e2),+             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2+    )+    return (OpApp fix e1 op e2)++----------------------------++-- | Name of an operator in an operator application or section+data OpName = NormalOp Name         -- ^ A normal identifier+            | NegateOp              -- ^ Prefix negation+            | UnboundOp OccName     -- ^ An unbound indentifier+            | RecFldOp (AmbiguousFieldOcc GhcRn)+              -- ^ A (possibly ambiguous) record field occurrence++instance Outputable OpName where+  ppr (NormalOp n)   = ppr n+  ppr NegateOp       = ppr negateName+  ppr (UnboundOp uv) = ppr uv+  ppr (RecFldOp fld) = ppr fld++get_op :: LHsExpr GhcRn -> OpName+-- An unbound name could be either HsVar or HsUnboundVar+-- See GHC.Rename.Expr.rnUnboundVar+get_op (L _ (HsVar _ n))         = NormalOp (unLoc n)+get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv+get_op (L _ (HsRecFld _ fld))    = RecFldOp fld+get_op other                     = pprPanic "get_op" (ppr other)++-- Parser left-associates everything, but+-- derived instances may have correctly-associated things to+-- in the right operand.  So we just check that the right operand is OK+right_op_ok :: Fixity -> HsExpr GhcRn -> Bool+right_op_ok fix1 (OpApp fix2 _ _ _)+  = not error_please && associate_right+  where+    (error_please, associate_right) = compareFixity fix1 fix2+right_op_ok _ _+  = True++-- Parser initially makes negation bind more tightly than any other operator+-- And "deriving" code should respect this (use HsPar if not)+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)+           -> RnM (HsExpr (GhcPass id))+mkNegAppRn neg_arg neg_name+  = ASSERT( not_op_app (unLoc neg_arg) )+    return (NegApp noExtField neg_arg neg_name)++not_op_app :: HsExpr id -> Bool+not_op_app (OpApp {}) = False+not_op_app _          = True++---------------------------+mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged+          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity+          -> LHsCmdTop GhcRn             -- Right operand (not an infix)+          -> RnM (HsCmd GhcRn)++-- (e11 `op1` e12) `op2` e2+mkOpFormRn a1@(L loc+                    (HsCmdTop _+                     (L _ (HsCmdArrForm x op1 f (Just fix1)+                        [a11,a12]))))+        op2 fix2 a2+  | nofix_error+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)+       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])++  | associate_right+  = do new_c <- mkOpFormRn a12 op2 fix2 a2+       return (HsCmdArrForm noExtField op1 f (Just fix1)+               [a11, L loc (HsCmdTop [] (L loc new_c))])+        -- TODO: locs are wrong+  where+    (nofix_error, associate_right) = compareFixity fix1 fix2++--      Default case+mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment+  = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])+++--------------------------------------+mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn+             -> RnM (Pat GhcRn)++mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2+  = do  { fix1 <- lookupFixityRn (unLoc op1)+        ; let (nofix_error, associate_right) = compareFixity fix1 fix2++        ; if nofix_error then do+                { precParseErr (NormalOp (unLoc op1),fix1)+                               (NormalOp (unLoc op2),fix2)+                ; return (ConPatIn op2 (InfixCon p1 p2)) }++          else if associate_right then do+                { new_p <- mkConOpPatRn op2 fix2 p12 p2+                ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) }+                -- XXX loc right?+          else return (ConPatIn op2 (InfixCon p1 p2)) }++mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment+  = ASSERT( not_op_pat (unLoc p2) )+    return (ConPatIn op (InfixCon p1 p2))++not_op_pat :: Pat GhcRn -> Bool+not_op_pat (ConPatIn _ (InfixCon _ _)) = False+not_op_pat _                           = True++--------------------------------------+checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()+  -- Check precedence of a function binding written infix+  --   eg  a `op` b `C` c = ...+  -- See comments with rnExpr (OpApp ...) about "deriving"++checkPrecMatch op (MG { mg_alts = (L _ ms) })+  = mapM_ check ms+  where+    check (L _ (Match { m_pats = (L l1 p1)+                               : (L l2 p2)+                               : _ }))+      = setSrcSpan (combineSrcSpans l1 l2) $+        do checkPrec op p1 False+           checkPrec op p2 True++    check _ = return ()+        -- This can happen.  Consider+        --      a `op` True = ...+        --      op          = ...+        -- The infix flag comes from the first binding of the group+        -- but the second eqn has no args (an error, but not discovered+        -- until the type checker).  So we don't want to crash on the+        -- second eqn.+checkPrecMatch _ (XMatchGroup nec) = noExtCon nec++checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()+checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do+    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op+    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)+    let+        inf_ok = op1_prec > op_prec ||+                 (op1_prec == op_prec &&+                  (op1_dir == InfixR && op_dir == InfixR && right ||+                   op1_dir == InfixL && op_dir == InfixL && not right))++        info  = (NormalOp op,          op_fix)+        info1 = (NormalOp (unLoc op1), op1_fix)+        (infol, infor) = if right then (info, info1) else (info1, info)+    unless inf_ok (precParseErr infol infor)++checkPrec _ _ _+  = return ()++-- Check precedence of (arg op) or (op arg) respectively+-- If arg is itself an operator application, then either+--   (a) its precedence must be higher than that of op+--   (b) its precedency & associativity must be the same as that of op+checkSectionPrec :: FixityDirection -> HsExpr GhcPs+        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()+checkSectionPrec direction section op arg+  = case unLoc arg of+        OpApp fix _ op' _ -> go_for_it (get_op op') fix+        NegApp _ _ _      -> go_for_it NegateOp     negateFixity+        _                 -> return ()+  where+    op_name = get_op op+    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do+          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name+          unless (op_prec < arg_prec+                  || (op_prec == arg_prec && direction == assoc))+                 (sectionPrecErr (get_op op, op_fix)+                                 (arg_op, arg_fix) section)++-- | Look up the fixity for an operator name.  Be careful to use+-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields+-- (see #13132).+lookupFixityOp :: OpName -> RnM Fixity+lookupFixityOp (NormalOp n)  = lookupFixityRn n+lookupFixityOp NegateOp      = lookupFixityRn negateName+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u)+lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f+++-- Precedence-related error messages++precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()+precParseErr op1@(n1,_) op2@(n2,_)+  | is_unbound n1 || is_unbound n2+  = return ()     -- Avoid error cascade+  | otherwise+  = addErr $ hang (text "Precedence parsing error")+      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),+               ppr_opfix op2,+               text "in the same infix expression"])++sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()+sectionPrecErr op@(n1,_) arg_op@(n2,_) section+  | is_unbound n1 || is_unbound n2+  = return ()     -- Avoid error cascade+  | otherwise+  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),+         nest 4 (sep [text "must have lower precedence than that of the operand,",+                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),+         nest 4 (text "in the section:" <+> quotes (ppr section))]++is_unbound :: OpName -> Bool+is_unbound (NormalOp n) = isUnboundName n+is_unbound UnboundOp{}  = True+is_unbound _            = False++ppr_opfix :: (OpName, Fixity) -> SDoc+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)+   where+     pp_op | NegateOp <- op = text "prefix `-'"+           | otherwise      = quotes (ppr op)+++{- *****************************************************+*                                                      *+                 Errors+*                                                      *+***************************************************** -}++unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc+unexpectedTypeSigErr ty+  = hang (text "Illegal type signature:" <+> quotes (ppr ty))+       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")++badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()+badKindSigErr doc (L loc ty)+  = setSrcSpan loc $ addErr $+    withHsDocContext doc $+    hang (text "Illegal kind signature:" <+> quotes (ppr ty))+       2 (text "Perhaps you intended to use KindSignatures")++dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc+dataKindsErr env thing+  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))+       2 (text "Perhaps you intended to use DataKinds")+  where+    pp_what | isRnKindLevel env = text "kind"+            | otherwise          = text "type"++inTypeDoc :: HsType GhcPs -> SDoc+inTypeDoc ty = text "In the type" <+> quotes (ppr ty)++warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()+warnUnusedForAll in_doc (L loc tv) used_names+  = whenWOptM Opt_WarnUnusedForalls $+    unless (hsTyVarName tv `elemNameSet` used_names) $+    addWarnAt (Reason Opt_WarnUnusedForalls) loc $+    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)+         , in_doc ]++opTyErr :: Outputable a => RdrName -> a -> SDoc+opTyErr op overall_ty+  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))+         2 (text "Use TypeOperators to allow operators in types")++{-+************************************************************************+*                                                                      *+      Finding the free type variables of a (HsType RdrName)+*                                                                      *+************************************************************************+++Note [Kind and type-variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type signature we may implicitly bind type/kind variables. For example:+  *   f :: a -> a+      f = ...+    Here we need to find the free type variables of (a -> a),+    so that we know what to quantify++  *   class C (a :: k) where ...+    This binds 'k' in ..., as well as 'a'++  *   f (x :: a -> [a]) = ....+    Here we bind 'a' in ....++  *   f (x :: T a -> T (b :: k)) = ...+    Here we bind both 'a' and the kind variable 'k'++  *   type instance F (T (a :: Maybe k)) = ...a...k...+    Here we want to constrain the kind of 'a', and bind 'k'.++To do that, we need to walk over a type and find its free type/kind variables.+We preserve the left-to-right order of each variable occurrence.+See Note [Ordering of implicit variables].++Clients of this code can remove duplicates with nubL.++Note [Ordering of implicit variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the advent of -XTypeApplications, GHC makes promises about the ordering+of implicit variable quantification. Specifically, we offer that implicitly+quantified variables (such as those in const :: a -> b -> a, without a `forall`)+will occur in left-to-right order of first occurrence. Here are a few examples:++  const :: a -> b -> a       -- forall a b. ...+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included++  type a <-< b = b -> a+  g :: a <-< b               -- forall a b. ...  type synonyms matter++  class Functor f where+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...+    -- The f is quantified by the class, so only a and b are considered in fmap++This simple story is complicated by the possibility of dependency: all variables+must come after any variables mentioned in their kinds.++  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...++The k comes first because a depends on k, even though the k appears later than+the a in the code. Thus, GHC does ScopedSort on the variables.+See Note [ScopedSort] in Type.++Implicitly bound variables are collected by any function which returns a+FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably+includes the `extract-` family of functions (extractHsTysRdrTyVarsDups,+extractHsTyVarBndrsKVs, etc.).+These functions thus promise to keep left-to-right ordering.++Note [Implicit quantification in type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We typically bind type/kind variables implicitly when they are in a kind+annotation on the LHS, for example:++  data Proxy (a :: k) = Proxy+  type KindOf (a :: k) = k++Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and+we want to implicitly quantify over it.  This is easy: just extract all free+variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs++By contrast, on the RHS we can't simply collect *all* free variables. Which of+the following are allowed?++  type TySyn1 = a :: Type+  type TySyn2 = 'Nothing :: Maybe a+  type TySyn3 = 'Just ('Nothing :: Maybe a)+  type TySyn4 = 'Left a :: Either Type a++After some design deliberations (see non-taken alternatives below), the answer+is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.+We implicitly quantify over free variables of the outermost kind signature, if+one exists:++  * In TySyn1, the outermost kind signature is (:: Type), and it does not have+    any free variables.+  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a+    free variable 'a', which we implicitly quantify over.+  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature+    is hidden inside 'Just.+  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains+    a free variable 'a', which we implicitly quantify over. That is why we can+    also use it to the left of the double colon: 'Left a++The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type+synonyms and type family instances.++This is something of a stopgap solution until we can explicitly bind invisible+type/kind variables:++  type TySyn3 :: forall a. Maybe a+  type TySyn3 @a = 'Just ('Nothing :: Maybe a)++Note [Implicit quantification in type synonyms: non-taken alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Alternative I: No quantification+--------------------------------+We could offer no implicit quantification on the RHS, accepting none of the+TySyn<N> examples. The user would have to bind the variables explicitly:++  type TySyn1 a = a :: Type+  type TySyn2 a = 'Nothing :: Maybe a+  type TySyn3 a = 'Just ('Nothing :: Maybe a)+  type TySyn4 a = 'Left a :: Either Type a++However, this would mean that one would have to specify 'a' at call sites every+time, which could be undesired.++Alternative II: Indiscriminate quantification+---------------------------------------------+We could implicitly quantify over all free variables on the RHS just like we do+on the LHS. Then we would infer the following kinds:++  TySyn1 :: forall {a}. Type+  TySyn2 :: forall {a}. Maybe a+  TySyn3 :: forall {a}. Maybe (Maybe a)+  TySyn4 :: forall {a}. Either Type a++This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable+is free-floating, not fixed by anything.++Alternative III: reportFloatingKvs+----------------------------------+We could augment Alternative II by hunting down free-floating variables during+type checking. While viable, this would mean we'd end up accepting this:++  data Prox k (a :: k)+  type T = Prox k++-}++-- See Note [Kind and type-variable binders]+-- These lists are guaranteed to preserve left-to-right ordering of+-- the types the variables were extracted from. See also+-- Note [Ordering of implicit variables].+type FreeKiTyVars = [Located RdrName]++-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.+type FreeKiTyVarsWithDups = FreeKiTyVars++-- | A 'FreeKiTyVars' list that contains no duplicate variables.+type FreeKiTyVarsNoDups   = FreeKiTyVars++filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars+filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)++filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars+filterInScopeM vars+  = do { rdr_env <- getLocalRdrEnv+       ; return (filterInScope rdr_env vars) }++inScope :: LocalRdrEnv -> RdrName -> Bool+inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env++extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_tyarg (HsValArg ty) acc = extract_lty ty acc+extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc+extract_tyarg (HsArgPar _) acc = acc++extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_tyargs args acc = foldr extract_tyarg acc args++extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups+extractHsTyArgRdrKiTyVarsDup args+  = extract_tyargs args []++-- | 'extractHsTyRdrTyVars' finds the type/kind variables+--                          of a HsType/HsKind.+-- It's used when making the @forall@s explicit.+-- When the same name occurs multiple times in the types, only the first+-- occurrence is returned.+-- See Note [Kind and type-variable binders]+extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups+extractHsTyRdrTyVars ty+  = nubL (extractHsTyRdrTyVarsDups ty)++-- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables+--                              of a HsType/HsKind.+-- It's used when making the @forall@s explicit.+-- When the same name occurs multiple times in the types, all occurrences+-- are returned.+extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups+extractHsTyRdrTyVarsDups ty+  = extract_lty ty []++-- | Extracts the free type/kind variables from the kind signature of a HsType.+--   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.+-- When the same name occurs multiple times in the type, only the first+-- occurrence is returned, and the left-to-right order of variables is+-- preserved.+-- See Note [Kind and type-variable binders] and+--     Note [Ordering of implicit variables] and+--     Note [Implicit quantification in type synonyms].+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups+extractHsTyRdrTyVarsKindVars (unLoc -> ty) =+  case ty of+    HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty+    HsKindSig _ _ ki -> extractHsTyRdrTyVars ki+    _ -> []++-- | Extracts free type and kind variables from types in a list.+-- When the same name occurs multiple times in the types, all occurrences+-- are returned.+extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups+extractHsTysRdrTyVarsDups tys+  = extract_ltys tys []++-- Returns the free kind variables of any explicitly-kinded binders, returning+-- variable occurrences in left-to-right order.+-- See Note [Ordering of implicit variables].+-- NB: Does /not/ delete the binders themselves.+--     However duplicates are removed+--     E.g. given  [k1, a:k1, b:k2]+--          the function returns [k1,k2], even though k1 is bound here+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups+extractHsTyVarBndrsKVs tv_bndrs+  = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)++-- Returns the free kind variables in a type family result signature, returning+-- variable occurrences in left-to-right order.+-- See Note [Ordering of implicit variables].+extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]+extractRdrKindSigVars (L _ resultSig)+  | KindSig _ k                          <- resultSig = extractHsTyRdrTyVars k+  | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k+  | otherwise =  []++-- Get type/kind variables mentioned in the kind signature, preserving+-- left-to-right order and without duplicates:+--+--  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]+--  * data T a (b :: k1)                             -- result: []+--+-- See Note [Ordering of implicit variables].+extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVarsNoDups+extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })+  = maybe [] extractHsTyRdrTyVars ksig+extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec++extract_lctxt :: LHsContext GhcPs+              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_lctxt ctxt = extract_ltys (unLoc ctxt)++extract_ltys :: [LHsType GhcPs]+             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_ltys tys acc = foldr extract_lty acc tys++extract_lty :: LHsType GhcPs+            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_lty (L _ ty) acc+  = case ty of+      HsTyVar _ _  ltv            -> extract_tv ltv acc+      HsBangTy _ _ ty             -> extract_lty ty acc+      HsRecTy _ flds              -> foldr (extract_lty+                                            . cd_fld_type . unLoc) acc+                                           flds+      HsAppTy _ ty1 ty2           -> extract_lty ty1 $+                                     extract_lty ty2 acc+      HsAppKindTy _ ty k          -> extract_lty ty $+                                     extract_lty k acc+      HsListTy _ ty               -> extract_lty ty acc+      HsTupleTy _ _ tys           -> extract_ltys tys acc+      HsSumTy _ tys               -> extract_ltys tys acc+      HsFunTy _ ty1 ty2           -> extract_lty ty1 $+                                     extract_lty ty2 acc+      HsIParamTy _ _ ty           -> extract_lty ty acc+      HsOpTy _ ty1 tv ty2         -> extract_tv tv $+                                     extract_lty ty1 $+                                     extract_lty ty2 acc+      HsParTy _ ty                -> extract_lty ty acc+      HsSpliceTy {}               -> acc  -- Type splices mention no tvs+      HsDocTy _ ty _              -> extract_lty ty acc+      HsExplicitListTy _ _ tys    -> extract_ltys tys acc+      HsExplicitTupleTy _ tys     -> extract_ltys tys acc+      HsTyLit _ _                 -> acc+      HsStarTy _ _                -> acc+      HsKindSig _ ty ki           -> extract_lty ty $+                                     extract_lty ki acc+      HsForAllTy { hst_bndrs = tvs, hst_body = ty }+                                  -> extract_hs_tv_bndrs tvs acc $+                                     extract_lty ty []+      HsQualTy { hst_ctxt = ctxt, hst_body = ty }+                                  -> extract_lctxt ctxt $+                                     extract_lty ty acc+      XHsType {}                  -> acc+      -- We deal with these separately in rnLHsTypeWithWildCards+      HsWildCardTy {}             -> acc++extractHsTvBndrs :: [LHsTyVarBndr GhcPs]+                 -> FreeKiTyVarsWithDups           -- Free in body+                 -> FreeKiTyVarsWithDups       -- Free in result+extractHsTvBndrs tv_bndrs body_fvs+  = extract_hs_tv_bndrs tv_bndrs [] body_fvs++extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]+                    -> FreeKiTyVarsWithDups  -- Accumulator+                    -> FreeKiTyVarsWithDups  -- Free in body+                    -> FreeKiTyVarsWithDups+-- In (forall (a :: Maybe e). a -> b) we have+--     'a' is bound by the forall+--     'b' is a free type variable+--     'e' is a free kind variable+extract_hs_tv_bndrs tv_bndrs acc_vars body_vars+  | null tv_bndrs = body_vars ++ acc_vars+  | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars+    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.+    -- See Note [Kind variable scoping]+  where+    bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs+    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs++extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]+-- Returns the free kind variables of any explicitly-kinded binders, returning+-- variable occurrences in left-to-right order.+-- See Note [Ordering of implicit variables].+-- NB: Does /not/ delete the binders themselves.+--     Duplicates are /not/ removed+--     E.g. given  [k1, a:k1, b:k2]+--          the function returns [k1,k2], even though k1 is bound here+extract_hs_tv_bndrs_kvs tv_bndrs =+    foldr extract_lty []+          [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]++extract_tv :: Located RdrName+           -> [Located RdrName] -> [Located RdrName]+extract_tv tv acc =+  if isRdrTyVar (unLoc tv) then tv:acc else acc++-- Deletes duplicates in a list of Located things.+--+-- Importantly, this function is stable with respect to the original ordering+-- of things in the list. This is important, as it is a property that GHC+-- relies on to maintain the left-to-right ordering of implicitly quantified+-- type variables.+-- See Note [Ordering of implicit variables].+nubL :: Eq a => [Located a] -> [Located a]+nubL = nubBy eqLocated++elemRdr :: Located RdrName -> [Located RdrName] -> Bool+elemRdr x = any (eqLocated x)
+ compiler/GHC/Rename/Unbound.hs view
@@ -0,0 +1,384 @@+{-++This module contains helper functions for reporting and creating+unbound variables.++-}+module GHC.Rename.Unbound+   ( mkUnboundName+   , mkUnboundNameRdr+   , isUnboundName+   , reportUnboundName+   , unknownNameSuggestions+   , WhereLooking(..)+   , unboundName+   , unboundNameX+   , notInScopeErr+   )+where++import GhcPrelude++import RdrName+import HscTypes+import TcRnMonad+import Name+import Module+import SrcLoc+import Outputable+import PrelNames ( mkUnboundName, isUnboundName, getUnique)+import Util+import Maybes+import DynFlags+import FastString+import Data.List+import Data.Function ( on )+import UniqDFM (udfmToList)++{-+************************************************************************+*                                                                      *+               What to do when a lookup fails+*                                                                      *+************************************************************************+-}++data WhereLooking = WL_Any        -- Any binding+                  | WL_Global     -- Any top-level binding (local or imported)+                  | WL_LocalTop   -- Any top-level binding in this module+                  | WL_LocalOnly+                        -- Only local bindings+                        -- (pattern synonyms declaractions,+                        -- see Note [Renaming pattern synonym variables])++mkUnboundNameRdr :: RdrName -> Name+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)++reportUnboundName :: RdrName -> RnM Name+reportUnboundName rdr = unboundName WL_Any rdr++unboundName :: WhereLooking -> RdrName -> RnM Name+unboundName wl rdr = unboundNameX wl rdr Outputable.empty++unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name+unboundNameX where_look rdr_name extra+  = do  { dflags <- getDynFlags+        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags+              err = notInScopeErr rdr_name $$ extra+        ; if not show_helpful_errors+          then addErr err+          else do { local_env  <- getLocalRdrEnv+                  ; global_env <- getGlobalRdrEnv+                  ; impInfo <- getImports+                  ; currmod <- getModule+                  ; hpt <- getHpt+                  ; let suggestions = unknownNameSuggestions_ where_look+                          dflags hpt currmod global_env local_env impInfo+                          rdr_name+                  ; addErr (err $$ suggestions) }+        ; return (mkUnboundNameRdr rdr_name) }++notInScopeErr :: RdrName -> SDoc+notInScopeErr rdr_name+  = hang (text "Not in scope:")+       2 (what <+> quotes (ppr rdr_name))+  where+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))++type HowInScope = Either SrcSpan ImpDeclSpec+     -- Left loc    =>  locally bound at loc+     -- Right ispec =>  imported as specified by ispec+++-- | Called from the typechecker (TcErrors) when we find an unbound variable+unknownNameSuggestions :: DynFlags+                       -> HomePackageTable -> Module+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails+                       -> RdrName -> SDoc+unknownNameSuggestions = unknownNameSuggestions_ WL_Any++unknownNameSuggestions_ :: WhereLooking -> DynFlags+                       -> HomePackageTable -> Module+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails+                       -> RdrName -> SDoc+unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env+                          imports tried_rdr_name =+    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$+    importSuggestions where_look global_env hpt+                      curr_mod imports tried_rdr_name $$+    extensionSuggestions tried_rdr_name+++similarNameSuggestions :: WhereLooking -> DynFlags+                        -> GlobalRdrEnv -> LocalRdrEnv+                        -> RdrName -> SDoc+similarNameSuggestions where_look dflags global_env+                        local_env tried_rdr_name+  = case suggest of+      []  -> Outputable.empty+      [p] -> perhaps <+> pp_item p+      ps  -> sep [ perhaps <+> text "one of these:"+                 , nest 2 (pprWithCommas pp_item ps) ]+  where+    all_possibilities :: [(String, (RdrName, HowInScope))]+    all_possibilities+       =  [ (showPpr dflags r, (r, Left loc))+          | (r,loc) <- local_possibilities local_env ]+       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]++    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities+    perhaps = text "Perhaps you meant"++    pp_item :: (RdrName, HowInScope) -> SDoc+    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined+        where loc' = case loc of+                     UnhelpfulSpan l -> parens (ppr l)+                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))+    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported+                              parens (text "imported from" <+> ppr (is_mod is))++    pp_ns :: RdrName -> SDoc+    pp_ns rdr | ns /= tried_ns = pprNameSpace ns+              | otherwise      = Outputable.empty+      where ns = rdrNameSpace rdr++    tried_occ     = rdrNameOcc tried_rdr_name+    tried_is_sym  = isSymOcc tried_occ+    tried_ns      = occNameSpace tried_occ+    tried_is_qual = isQual tried_rdr_name++    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns+                           && isSymOcc occ == tried_is_sym+        -- Treat operator and non-operators as non-matching+        -- This heuristic avoids things like+        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)++    local_ok = case where_look of { WL_Any -> True+                                  ; WL_LocalOnly -> True+                                  ; _ -> False }+    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]+    local_possibilities env+      | tried_is_qual = []+      | not local_ok  = []+      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)+                        | name <- localRdrEnvElts env+                        , let occ = nameOccName name+                        , correct_name_space occ]++    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]+    global_possibilities global_env+      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))+                        | gre <- globalRdrEnvElts global_env+                        , isGreOk where_look gre+                        , let name = gre_name gre+                              occ  = nameOccName name+                        , correct_name_space occ+                        , (mod, how) <- qualsInScope gre+                        , let rdr_qual = mkRdrQual mod occ ]++      | otherwise = [ (rdr_unqual, pair)+                    | gre <- globalRdrEnvElts global_env+                    , isGreOk where_look gre+                    , let name = gre_name gre+                          occ  = nameOccName name+                          rdr_unqual = mkRdrUnqual occ+                    , correct_name_space occ+                    , pair <- case (unquals_in_scope gre, quals_only gre) of+                                (how:_, _)    -> [ (rdr_unqual, how) ]+                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]+                                ([],    [])   -> [] ]++              -- Note [Only-quals]+              -- The second alternative returns those names with the same+              -- OccName as the one we tried, but live in *qualified* imports+              -- e.g. if you have:+              --+              -- > import qualified Data.Map as Map+              -- > foo :: Map+              --+              -- then we suggest @Map.Map@.++    --------------------+    unquals_in_scope :: GlobalRdrElt -> [HowInScope]+    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })+      | lcl       = [ Left (nameSrcSpan n) ]+      | otherwise = [ Right ispec+                    | i <- is, let ispec = is_decl i+                    , not (is_qual ispec) ]+++    --------------------+    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]+    -- Ones for which *only* the qualified version is in scope+    quals_only (GRE { gre_name = n, gre_imp = is })+      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)+        | i <- is, let ispec = is_decl i, is_qual ispec ]++-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.+importSuggestions :: WhereLooking+                  -> GlobalRdrEnv+                  -> HomePackageTable -> Module+                  -> ImportAvails -> RdrName -> SDoc+importSuggestions where_look global_env hpt currMod imports rdr_name+  | WL_LocalOnly <- where_look                 = Outputable.empty+  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty+  | null interesting_imports+  , Just name <- mod_name+  , show_not_imported_line name+  = hsep+      [ text "No module named"+      , quotes (ppr name)+      , text "is imported."+      ]+  | is_qualified+  , null helpful_imports+  , [(mod,_)] <- interesting_imports+  = hsep+      [ text "Module"+      , quotes (ppr mod)+      , text "does not export"+      , quotes (ppr occ_name) <> dot+      ]+  | is_qualified+  , null helpful_imports+  , not (null interesting_imports)+  , mods <- map fst interesting_imports+  = hsep+      [ text "Neither"+      , quotedListWithNor (map ppr mods)+      , text "exports"+      , quotes (ppr occ_name) <> dot+      ]+  | [(mod,imv)] <- helpful_imports_non_hiding+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to the import list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | not (null helpful_imports_non_hiding)+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to one of these import lists:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- helpful_imports_non_hiding+        ])+  | [(mod,imv)] <- helpful_imports_hiding+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the explicit hiding list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | not (null helpful_imports_hiding)+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the hiding clauses"+      , text "in one of these imports:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- helpful_imports_hiding+        ])+  | otherwise+  = Outputable.empty+ where+  is_qualified = isQual rdr_name+  (mod_name, occ_name) = case rdr_name of+    Unqual occ_name        -> (Nothing, occ_name)+    Qual mod_name occ_name -> (Just mod_name, occ_name)+    _                      -> error "importSuggestions: dead code"+++  -- What import statements provide "Mod" at all+  -- or, if this is an unqualified name, are not qualified imports+  interesting_imports = [ (mod, imp)+    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)+    , Just imp <- return $ pick (importedByUser mod_imports)+    ]++  -- We want to keep only one for each original module; preferably one with an+  -- explicit import list (for no particularly good reason)+  pick :: [ImportedModsVal] -> Maybe ImportedModsVal+  pick = listToMaybe . sortBy (compare `on` prefer) . filter select+    where select imv = case mod_name of Just name -> imv_name imv == name+                                        Nothing   -> not (imv_qualified imv)+          prefer imv = (imv_is_hiding imv, imv_span imv)++  -- Which of these would export a 'foo'+  -- (all of these are restricted imports, because if they were not, we+  -- wouldn't have an out-of-scope error in the first place)+  helpful_imports = filter helpful interesting_imports+    where helpful (_,imv)+            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name++  -- Which of these do that because of an explicit hiding list resp. an+  -- explicit import list+  (helpful_imports_hiding, helpful_imports_non_hiding)+    = partition (imv_is_hiding . snd) helpful_imports++  -- See note [When to show/hide the module-not-imported line]+  show_not_imported_line :: ModuleName -> Bool                    -- #15611+  show_not_imported_line modnam+      | modnam `elem` globMods                = False    -- #14225     -- 1+      | moduleName currMod == modnam          = False                  -- 2.1+      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2+      | otherwise                             = True+    where+      hpt_uniques = map fst (udfmToList hpt)+      is_last_loaded_mod _ []         = False+      is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam+      globMods = nub [ mod+                     | gre <- globalRdrEnvElts global_env+                     , isGreOk where_look gre+                     , (mod, _) <- qualsInScope gre+                     ]++extensionSuggestions :: RdrName -> SDoc+extensionSuggestions rdrName+  | rdrName == mkUnqual varName (fsLit "mdo") ||+    rdrName == mkUnqual varName (fsLit "rec")+      = text "Perhaps you meant to use RecursiveDo"+  | otherwise = Outputable.empty++qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]+-- Ones for which the qualified version is in scope+qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }+      | lcl = case nameModule_maybe n of+                Nothing -> []+                Just m  -> [(moduleName m, Left (nameSrcSpan n))]+      | otherwise = [ (is_as ispec, Right ispec)+                    | i <- is, let ispec = is_decl i ]++isGreOk :: WhereLooking -> GlobalRdrElt -> Bool+isGreOk where_look = case where_look of+                         WL_LocalTop  -> isLocalGRE+                         WL_LocalOnly -> const False+                         _            -> const True++{- Note [When to show/hide the module-not-imported line]           -- #15611+For the error message:+    Not in scope X.Y+    Module X does not export Y+    No module named ‘X’ is imported:+there are 2 cases, where we hide the last "no module is imported" line:+1. If the module X has been imported.+2. If the module X is the current module. There are 2 subcases:+   2.1 If the unknown module name is in a input source file,+       then we can use the getModule function to get the current module name.+       (See test T15611a)+   2.2 If the unknown module name has been entered by the user in GHCi,+       then the getModule function returns something like "interactive:Ghci1",+       and we have to check the current module in the last added entry of+       the HomePackageTable. (See test T15611b)+-}
+ compiler/GHC/Rename/Utils.hs view
@@ -0,0 +1,516 @@+{-++This module contains miscellaneous functions related to renaming.++-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Rename.Utils (+        checkDupRdrNames, checkShadowedRdrNames,+        checkDupNames, checkDupAndShadowedNames, dupNamesErr,+        checkTupSize,+        addFvRn, mapFvRn, mapMaybeFvRn,+        warnUnusedMatches, warnUnusedTypePatterns,+        warnUnusedTopBinds, warnUnusedLocalBinds,+        checkUnusedRecordWildcard,+        mkFieldEnv,+        unknownSubordinateErr, badQualBndrErr, typeAppErr,+        HsDocContext(..), pprHsDocContext,+        inHsDocContext, withHsDocContext,++        newLocalBndrRn, newLocalBndrsRn,++        bindLocalNames, bindLocalNamesFV,++        addNameClashErrRn, extendTyVarEnvFVRn++)++where+++import GhcPrelude++import GHC.Hs+import RdrName+import HscTypes+import TcEnv+import TcRnMonad+import Name+import NameSet+import NameEnv+import DataCon+import SrcLoc+import Outputable+import Util+import BasicTypes       ( TopLevelFlag(..) )+import ListSetOps       ( removeDups )+import DynFlags+import FastString+import Control.Monad+import Data.List+import Constants        ( mAX_TUPLE_SIZE )+import qualified Data.List.NonEmpty as NE+import qualified GHC.LanguageExtensions as LangExt++{-+*********************************************************+*                                                      *+\subsection{Binding}+*                                                      *+*********************************************************+-}++newLocalBndrRn :: Located RdrName -> RnM Name+-- Used for non-top-level binders.  These should+-- never be qualified.+newLocalBndrRn (L loc rdr_name)+  | Just name <- isExact_maybe rdr_name+  = return name -- This happens in code generated by Template Haskell+                -- See Note [Binders in Template Haskell] in Convert.hs+  | otherwise+  = do { unless (isUnqual rdr_name)+                (addErrAt loc (badQualBndrErr rdr_name))+       ; uniq <- newUnique+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }++newLocalBndrsRn :: [Located RdrName] -> RnM [Name]+newLocalBndrsRn = mapM newLocalBndrRn++bindLocalNames :: [Name] -> RnM a -> RnM a+bindLocalNames names enclosed_scope+  = do { lcl_env <- getLclEnv+       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)+             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)+                           [ (n, (NotTopLevel, th_level)) | n <- names ]+             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names+       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'+                            , tcl_rdr      = rdr_env' })+                    enclosed_scope }++bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)+bindLocalNamesFV names enclosed_scope+  = do  { (result, fvs) <- bindLocalNames names enclosed_scope+        ; return (result, delFVs names fvs) }++-------------------------------------++extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside++-------------------------------------+checkDupRdrNames :: [Located RdrName] -> RnM ()+-- Check for duplicated names in a binding group+checkDupRdrNames rdr_names_w_loc+  = mapM_ (dupNamesErr getLoc) dups+  where+    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc++checkDupNames :: [Name] -> RnM ()+-- Check for duplicated names in a binding group+checkDupNames names = check_dup_names (filterOut isSystemName names)+                -- See Note [Binders in Template Haskell] in Convert++check_dup_names :: [Name] -> RnM ()+check_dup_names names+  = mapM_ (dupNamesErr nameSrcSpan) dups+  where+    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names++---------------------+checkShadowedRdrNames :: [Located RdrName] -> RnM ()+checkShadowedRdrNames loc_rdr_names+  = do { envs <- getRdrEnvs+       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }+  where+    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names+                -- See Note [Binders in Template Haskell] in Convert+    get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)++checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()+checkDupAndShadowedNames envs names+  = do { check_dup_names filtered_names+       ; checkShadowedOccs envs get_loc_occ filtered_names }+  where+    filtered_names = filterOut isSystemName names+                -- See Note [Binders in Template Haskell] in Convert+    get_loc_occ name = (nameSrcSpan name, nameOccName name)++-------------------------------------+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)+                  -> (a -> (SrcSpan, OccName))+                  -> [a] -> RnM ()+checkShadowedOccs (global_env,local_env) get_loc_occ ns+  = whenWOptM Opt_WarnNameShadowing $+    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))+        ; mapM_ check_shadow ns }+  where+    check_shadow n+        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"+                                                -- See #3262+        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]+        | otherwise = do { gres' <- filterM is_shadowed_gre gres+                         ; complain (map pprNameProvenance gres') }+        where+          (loc,occ) = get_loc_occ n+          mb_local  = lookupLocalRdrOcc local_env occ+          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env+                -- Make an Unqualified RdrName and look that up, so that+                -- we don't find any GREs that are in scope qualified-only++          complain []      = return ()+          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)+                                       loc+                                       (shadowedNameWarn occ pp_locs)++    is_shadowed_gre :: GlobalRdrElt -> RnM Bool+        -- Returns False for record selectors that are shadowed, when+        -- punning or wild-cards are on (cf #2723)+    is_shadowed_gre gre | isRecFldGRE gre+        = do { dflags <- getDynFlags+             ; return $ not (xopt LangExt.RecordPuns dflags+                             || xopt LangExt.RecordWildCards dflags) }+    is_shadowed_gre _other = return True+++{-+************************************************************************+*                                                                      *+\subsection{Free variable manipulation}+*                                                                      *+************************************************************************+-}++-- A useful utility+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside+                               ; return (res, fvs1 `plusFV` fvs2) }++mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)+mapFvRn f xs = do stuff <- mapM f xs+                  case unzip stuff of+                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)++mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }++{-+************************************************************************+*                                                                      *+\subsection{Envt utility functions}+*                                                                      *+************************************************************************+-}++warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()+warnUnusedTopBinds gres+    = whenWOptM Opt_WarnUnusedTopBinds+    $ do env <- getGblEnv+         let isBoot = tcg_src env == HsBootFile+         let noParent gre = case gre_par gre of+                            NoParent -> True+                            _        -> False+             -- Don't warn about unused bindings with parents in+             -- .hs-boot files, as you are sometimes required to give+             -- unused bindings (trac #3449).+             -- HOWEVER, in a signature file, you are never obligated to put a+             -- definition in the main text.  Thus, if you define something+             -- and forget to export it, we really DO want to warn.+             gres' = if isBoot then filter noParent gres+                               else                 gres+         warnUnusedGREs gres'+++-- | Checks to see if we need to warn for -Wunused-record-wildcards or+-- -Wredundant-record-wildcards+checkUnusedRecordWildcard :: SrcSpan+                          -> FreeVars+                          -> Maybe [Name]+                          -> RnM ()+checkUnusedRecordWildcard _ _ Nothing    = return ()+checkUnusedRecordWildcard loc _ (Just [])  = do+  -- Add a new warning if the .. pattern binds no variables+  setSrcSpan loc $ warnRedundantRecordWildcard+checkUnusedRecordWildcard loc fvs (Just dotdot_names) =+  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs+++-- | Produce a warning when the `..` pattern binds no new+-- variables.+--+-- @+--   data P = P { x :: Int }+--+--   foo (P{x, ..}) = x+-- @+--+-- The `..` here doesn't bind any variables as `x` is already bound.+warnRedundantRecordWildcard :: RnM ()+warnRedundantRecordWildcard =+  whenWOptM Opt_WarnRedundantRecordWildcards+            (addWarn (Reason Opt_WarnRedundantRecordWildcards)+                     redundantWildcardWarning)+++-- | Produce a warning when no variables bound by a `..` pattern are used.+--+-- @+--   data P = P { x :: Int }+--+--   foo (P{..}) = ()+-- @+--+-- The `..` pattern binds `x` but it is not used in the RHS so we issue+-- a warning.+warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()+warnUnusedRecordWildcard ns used_names = do+  let used = filter (`elemNameSet` used_names) ns+  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)+  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)+    unusedRecordWildcardWarning++++warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns+  :: [Name] -> FreeVars -> RnM ()+warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds+warnUnusedMatches      = check_unused Opt_WarnUnusedMatches+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns++check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()+check_unused flag bound_names used_names+  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)+                                               bound_names))++-------------------------+--      Helpers+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()+warnUnusedGREs gres = mapM_ warnUnusedGRE gres++warnUnused :: WarningFlag -> [Name] -> RnM ()+warnUnused flag names = do+    fld_env <- mkFieldEnv <$> getGlobalRdrEnv+    mapM_ (warnUnused1 flag fld_env) names++warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()+warnUnused1 flag fld_env name+  = when (reportable name occ) $+    addUnusedWarning flag+                     occ (nameSrcSpan name)+                     (text $ "Defined but not used" ++ opt_str)+  where+    occ = case lookupNameEnv fld_env name of+              Just (fl, _) -> mkVarOccFS fl+              Nothing      -> nameOccName name+    opt_str = case flag of+                Opt_WarnUnusedTypePatterns -> " on the right hand side"+                _ -> ""++warnUnusedGRE :: GlobalRdrElt -> RnM ()+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })+  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv+                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name+  | otherwise = when (reportable name occ) (mapM_ warn is)+  where+    occ = greOccName gre+    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg+        where+           span = importSpecLoc spec+           pp_mod = quotes (ppr (importSpecModule spec))+           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")++-- | Make a map from selector names to field labels and parent tycon+-- names, to be used when reporting unused record fields.+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))+                               | gres <- occEnvElts rdr_env+                               , gre <- gres+                               , Just lbl <- [greLabel gre]+                               ]++-- | Should we report the fact that this 'Name' is unused? The+-- 'OccName' may differ from 'nameOccName' due to+-- DuplicateRecordFields.+reportable :: Name -> OccName -> Bool+reportable name occ+  | isWiredInName name = False    -- Don't report unused wired-in names+                                  -- Otherwise we get a zillion warnings+                                  -- from Data.Tuple+  | otherwise = not (startsWithUnderscore occ)++addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()+addUnusedWarning flag occ span msg+  = addWarnAt (Reason flag) span $+    sep [msg <> colon,+         nest 2 $ pprNonVarNameSpace (occNameSpace occ)+                        <+> quotes (ppr occ)]++unusedRecordWildcardWarning :: SDoc+unusedRecordWildcardWarning =+  wildcardDoc $ text "No variables bound in the record wildcard match are used"++redundantWildcardWarning :: SDoc+redundantWildcardWarning =+  wildcardDoc $ text "Record wildcard does not bind any new variables"++wildcardDoc :: SDoc -> SDoc+wildcardDoc herald =+  herald+    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"+                                            <+> quotes (text ".."))++addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()+addNameClashErrRn rdr_name gres+  | all isLocalGRE gres && not (all isRecFldGRE gres)+               -- If there are two or more *local* defns, we'll have reported+  = return ()  -- that already, and we don't want an error cascade+  | otherwise+  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)+                 , text "It could refer to"+                 , nest 3 (vcat (msg1 : msgs)) ])+  where+    (np1:nps) = gres+    msg1 =  text "either" <+> ppr_gre np1+    msgs = [text "    or" <+> ppr_gre np | np <- nps]+    ppr_gre gre = sep [ pp_gre_name gre <> comma+                      , pprNameProvenance gre]++    -- When printing the name, take care to qualify it in the same+    -- way as the provenance reported by pprNameProvenance, namely+    -- the head of 'gre_imp'.  Otherwise we get confusing reports like+    --   Ambiguous occurrence ‘null’+    --   It could refer to either ‘T15487a.null’,+    --                            imported from ‘Prelude’ at T15487.hs:1:8-13+    --                     or ...+    -- See #15487+    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent+                         , gre_lcl = lcl, gre_imp = iss })+      | FldParent { par_lbl = Just lbl } <- parent+      = text "the field" <+> quotes (ppr lbl)+      | otherwise+      = quotes (pp_qual <> dot <> ppr (nameOccName name))+      where+        pp_qual | lcl+                = ppr (nameModule name)+                | imp : _ <- iss  -- This 'imp' is the one that+                                  -- pprNameProvenance chooses+                , ImpDeclSpec { is_as = mod } <- is_decl imp+                = ppr mod+                | otherwise+                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)+                  -- Invariant: either 'lcl' is True or 'iss' is non-empty++shadowedNameWarn :: OccName -> [SDoc] -> SDoc+shadowedNameWarn occ shadowed_locs+  = sep [text "This binding for" <+> quotes (ppr occ)+            <+> text "shadows the existing binding" <> plural shadowed_locs,+         nest 2 (vcat shadowed_locs)]+++unknownSubordinateErr :: SDoc -> RdrName -> SDoc+unknownSubordinateErr doc op    -- Doc is "method of class" or+                                -- "field of constructor"+  = quotes (ppr op) <+> text "is not a (visible)" <+> doc+++dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()+dupNamesErr get_loc names+  = addErrAt big_loc $+    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),+          locations]+  where+    locs      = map get_loc (NE.toList names)+    big_loc   = foldr1 combineSrcSpans locs+    locations = text "Bound at:" <+> vcat (map ppr (sort locs))++badQualBndrErr :: RdrName -> SDoc+badQualBndrErr rdr_name+  = text "Qualified name in binding position:" <+> ppr rdr_name++typeAppErr :: String -> LHsType GhcPs -> SDoc+typeAppErr what (L _ k)+  = hang (text "Illegal visible" <+> text what <+> text "application"+            <+> quotes (char '@' <> ppr k))+       2 (text "Perhaps you intended to use TypeApplications")++checkTupSize :: Int -> RnM ()+checkTupSize tup_size+  | tup_size <= mAX_TUPLE_SIZE+  = return ()+  | otherwise+  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),+                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),+                 nest 2 (text "Workaround: use nested tuples or define a data type")])+++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++-- AZ:TODO: Change these all to be Name instead of RdrName.+--          Merge TcType.UserTypeContext in to it.+data HsDocContext+  = TypeSigCtx SDoc+  | StandaloneKindSigCtx SDoc+  | PatCtx+  | SpecInstSigCtx+  | DefaultDeclCtx+  | ForeignDeclCtx (Located RdrName)+  | DerivDeclCtx+  | RuleCtx FastString+  | TyDataCtx (Located RdrName)+  | TySynCtx (Located RdrName)+  | TyFamilyCtx (Located RdrName)+  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance+  | ConDeclCtx [Located Name]+  | ClassDeclCtx (Located RdrName)+  | ExprWithTySigCtx+  | TypBrCtx+  | HsTypeCtx+  | GHCiCtx+  | SpliceTypeCtx (LHsType GhcPs)+  | ClassInstanceCtx+  | GenericCtx SDoc   -- Maybe we want to use this more!++withHsDocContext :: HsDocContext -> SDoc -> SDoc+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt++inHsDocContext :: HsDocContext -> SDoc+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt++pprHsDocContext :: HsDocContext -> SDoc+pprHsDocContext (GenericCtx doc)      = doc+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc+pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc+pprHsDocContext PatCtx                = text "a pattern type-signature"+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"+pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"+pprHsDocContext HsTypeCtx             = text "a type argument"+pprHsDocContext GHCiCtx               = text "GHCi input"+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)+pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"++pprHsDocContext (ForeignDeclCtx name)+   = text "the foreign declaration for" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx [name])+   = text "the definition of data constructor" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx names)+   = text "the definition of data constructors" <+> interpp'SP names
compiler/GHC/Stg/FVs.hs view
@@ -1,4 +1,42 @@--- | Free variable analysis on STG terms.+{- |+Non-global free variable analysis on STG terms. This pass annotates+non-top-level closure bindings with captured variables. Global variables are not+captured. For example, in a top-level binding like (pseudo-STG)++    f = \[x,y] .+      let g = \[p] . reverse (x ++ p)+      in g y++In g, `reverse` and `(++)` are global variables so they're not considered free.+`p` is an argument, so `x` is the only actual free variable here. The annotated+version is thus:++    f = \[x,y] .+      let g = [x] \[p] . reverse (x ++ p)+      in g y++Note that non-top-level recursive bindings are also considered free within the+group:++    map = {} \r [f xs0]+      let {+        Rec {+          go = {f, go} \r [xs1]+            case xs1 of {+              [] -> [] [];+              : x xs2 ->+                  let { xs' = {go, xs2} \u [] go xs2; } in+                  let { x' = {f, x} \u [] f x; } in+                  : [x' xs'];+            };+        end Rec }+      } in go xs0;++Here go is free in its RHS.++Top-level closure bindings never capture variables as all of their free+variables are global.+-} module GHC.Stg.FVs (     annTopBindingsFreeVars,     annBindingFreeVars
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -26,7 +26,7 @@ import Demand import DynFlags import Id-import SMRep ( WordOff )+import GHC.Runtime.Layout ( WordOff ) import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure
− compiler/GHC/Stg/Syntax.hs 
@@ -1,871 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--Shared term graph (STG) syntax for spineless-tagless code generation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--This data type represents programs just before code generation (conversion to-@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style-being one that happens to be ideally suited to spineless tagless code-generation.--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}--module GHC.Stg.Syntax (-        StgArg(..),--        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),-        GenStgAlt, AltType(..),--        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,-        NoExtFieldSilent, noExtFieldSilent,-        OutputablePass,--        UpdateFlag(..), isUpdatable,--        -- a set of synonyms for the vanilla parameterisation-        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,--        -- a set of synonyms for the code gen parameterisation-        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,--        -- a set of synonyms for the lambda lifting parameterisation-        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,--        -- a set of synonyms to distinguish in- and out variants-        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,-        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,--        -- StgOp-        StgOp(..),--        -- utils-        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,-        isDllConApp,-        stgArgType,-        stripStgTicksTop, stripStgTicksTopE,-        stgCaseBndrInScope,--        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings-    ) where--#include "HsVersions.h"--import GhcPrelude--import CoreSyn     ( AltCon, Tickish )-import CostCentre  ( CostCentreStack )-import Data.ByteString ( ByteString )-import Data.Data   ( Data )-import Data.List   ( intersperse )-import DataCon-import DynFlags-import ForeignCall ( ForeignCall )-import Id-import IdInfo      ( mayHaveCafRefs )-import VarSet-import Literal     ( Literal, literalType )-import Module      ( Module )-import Outputable-import Packages    ( isDllName )-import GHC.Platform-import PprCore     ( {- instances -} )-import PrimOp      ( PrimOp, PrimCall )-import TyCon       ( PrimRep(..), TyCon )-import Type        ( Type )-import GHC.Types.RepType     ( typePrimRep1 )-import Util--import Data.List.NonEmpty ( NonEmpty, toList )--{--************************************************************************-*                                                                      *-GenStgBinding-*                                                                      *-************************************************************************--As usual, expressions are interesting; other things are boring. Here are the-boring things (except note the @GenStgRhs@), parameterised with respect to-binder and occurrence information (just as in @CoreSyn@):--}---- | A top-level binding.-data GenStgTopBinding pass--- See Note [CoreSyn top-level string literals]-  = StgTopLifted (GenStgBinding pass)-  | StgTopStringLit Id ByteString--data GenStgBinding pass-  = StgNonRec (BinderP pass) (GenStgRhs pass)-  | StgRec    [(BinderP pass, GenStgRhs pass)]--{--************************************************************************-*                                                                      *-StgArg-*                                                                      *-************************************************************************--}--data StgArg-  = StgVarArg  Id-  | StgLitArg  Literal---- | Does this constructor application refer to anything in a different--- *Windows* DLL?--- If so, we can't allocate it statically-isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool-isDllConApp dflags this_mod con args- | platformOS (targetPlatform dflags) == OSMinGW32-    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args- | otherwise = False-  where-    -- NB: typePrimRep1 is legit because any free variables won't have-    -- unlifted type (there are no unlifted things at top level)-    is_dll_arg :: StgArg -> Bool-    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))-                             && isDllName dflags this_mod (idName v)-    is_dll_arg _             = False---- True of machine addresses; these are the things that don't work across DLLs.--- The key point here is that VoidRep comes out False, so that a top level--- nullary GADT constructor is False for isDllConApp------    data T a where---      T1 :: T Int------ gives------    T1 :: forall a. (a~Int) -> T a------ and hence the top-level binding------    $WT1 :: T Int---    $WT1 = T1 Int (Coercion (Refl Int))------ The coercion argument here gets VoidRep-isAddrRep :: PrimRep -> Bool-isAddrRep AddrRep     = True-isAddrRep LiftedRep   = True-isAddrRep UnliftedRep = True-isAddrRep _           = False---- | Type of an @StgArg@------ Very half baked because we have lost the type arguments.-stgArgType :: StgArg -> Type-stgArgType (StgVarArg v)   = idType v-stgArgType (StgLitArg lit) = literalType lit----- | Strip ticks of a given type from an STG expression.-stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)-stripStgTicksTop p = go []-   where go ts (StgTick t e) | p t = go (t:ts) e-         go ts other               = (reverse ts, other)---- | Strip ticks of a given type from an STG expression returning only the expression.-stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p-stripStgTicksTopE p = go-   where go (StgTick t e) | p t = go e-         go other               = other---- | Given an alt type and whether the program is unarised, return whether the--- case binder is in scope.------ Case binders of unboxed tuple or unboxed sum type always dead after the--- unariser has run. See Note [Post-unarisation invariants].-stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool-stgCaseBndrInScope alt_ty unarised =-    case alt_ty of-      AlgAlt _      -> True-      PrimAlt _     -> True-      MultiValAlt _ -> not unarised-      PolyAlt       -> True--{--************************************************************************-*                                                                      *-STG expressions-*                                                                      *-************************************************************************--The @GenStgExpr@ data type is parameterised on binder and occurrence info, as-before.--************************************************************************-*                                                                      *-GenStgExpr-*                                                                      *-************************************************************************--An application is of a function to a list of atoms (not expressions).-Operationally, we want to push the arguments on the stack and call the function.-(If the arguments were expressions, we would have to build their closures-first.)--There is no constructor for a lone variable; it would appear as @StgApp var []@.--}--data GenStgExpr pass-  = StgApp-        Id       -- function-        [StgArg] -- arguments; may be empty--{--************************************************************************-*                                                                      *-StgConApp and StgPrimApp --- saturated applications-*                                                                      *-************************************************************************--There are specialised forms of application, for constructors, primitives, and-literals.--}--  | StgLit      Literal--        -- StgConApp is vital for returning unboxed tuples or sums-        -- which can't be let-bound-  | StgConApp   DataCon-                [StgArg] -- Saturated-                [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise--  | StgOpApp    StgOp    -- Primitive op or foreign call-                [StgArg] -- Saturated.-                Type     -- Result type-                         -- We need to know this so that we can-                         -- assign result registers--{--************************************************************************-*                                                                      *-StgLam-*                                                                      *-************************************************************************--StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it-encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension-to GenStgExpr à la TTG.--}--  | StgLam-        (NonEmpty (BinderP pass))-        StgExpr    -- Body of lambda--{--************************************************************************-*                                                                      *-GenStgExpr: case-expressions-*                                                                      *-************************************************************************--This has the same boxed/unboxed business as Core case expressions.--}--  | StgCase-        (GenStgExpr pass) -- the thing to examine-        (BinderP pass) -- binds the result of evaluating the scrutinee-        AltType-        [GenStgAlt pass]-                    -- The DEFAULT case is always *first*-                    -- if it is there at all--{--************************************************************************-*                                                                      *-GenStgExpr: let(rec)-expressions-*                                                                      *-************************************************************************--The various forms of let(rec)-expression encode most of the interesting things-we want to do.---   let-closure x = [free-vars] [args] expr in e--  is equivalent to--    let x = (\free-vars -> \args -> expr) free-vars--  @args@ may be empty (and is for most closures). It isn't under circumstances-  like this:--    let x = (\y -> y+z)--  This gets mangled to--    let-closure x = [z] [y] (y+z)--  The idea is that we compile code for @(y+z)@ in an environment in which @z@ is-  bound to an offset from Node, and `y` is bound to an offset from the stack-  pointer.--  (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)---   let-constructor x = Constructor [args] in e--  (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)--- Letrec-expressions are essentially the same deal as let-closure/-  let-constructor, so we use a common structure and distinguish between them-  with an @is_recursive@ boolean flag.---   let-unboxed u = <an arbitrary arithmetic expression in unboxed values> in e--  All the stuff on the RHS must be fully evaluated. No function calls either!--  (We've backed away from this toward case-expressions with suitably-magical-  alts ...)--- Advanced stuff here! Not to start with, but makes pattern matching generate-  more efficient code.--    let-escapes-not fail = expr-    in e'--  Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,-  or pass it to another function. All @e'@ will ever do is tail-call @fail@.-  Rather than build a closure for @fail@, all we need do is to record the stack-  level at the moment of the @let-escapes-not@; then entering @fail@ is just a-  matter of adjusting the stack pointer back down to that point and entering the-  code for it.--  Another example:--    f x y = let z = huge-expression in-            if y==1 then z else-            if y==2 then z else-            1--  (A let-escapes-not is an @StgLetNoEscape@.)--- We may eventually want:--    let-literal x = Literal in e--And so the code for let(rec)-things:--}--  | StgLet-        (XLet pass)-        (GenStgBinding pass)    -- right hand sides (see below)-        (GenStgExpr pass)       -- body--  | StgLetNoEscape-        (XLetNoEscape pass)-        (GenStgBinding pass)    -- right hand sides (see below)-        (GenStgExpr pass)       -- body--{--*************************************************************************-*                                                                      *-GenStgExpr: hpc, scc and other debug annotations-*                                                                      *-*************************************************************************--Finally for @hpc@ expressions we introduce a new STG construct.--}--  | StgTick-    (Tickish Id)-    (GenStgExpr pass)       -- sub expression---- END of GenStgExpr--{--************************************************************************-*                                                                      *-STG right-hand sides-*                                                                      *-************************************************************************--Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for-closures:--}--data GenStgRhs pass-  = StgRhsClosure-        (XRhsClosure pass) -- ^ Extension point for non-global free var-                           --   list just before 'CodeGen'.-        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)-        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'-        [BinderP pass]     -- ^ arguments; if empty, then not a function;-                           --   as above, order is important.-        (GenStgExpr pass)  -- ^ body--{--An example may be in order.  Consider:--  let t = \x -> \y -> ... x ... y ... p ... q in e--Pulling out the free vars and stylising somewhat, we get the equivalent:--  let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q--Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from-@Node@ into the closure, and the code ptr for the closure will be exactly that-in parentheses above.--The second flavour of right-hand-side is for constructors (simple but-important):--}--  | StgRhsCon-        CostCentreStack -- CCS to be attached (default is CurrentCCS).-                        -- Top-level (static) ones will end up with-                        -- DontCareCCS, because we don't count static-                        -- data in heap profiles, and we don't set CCCS-                        -- from static closure.-        DataCon         -- Constructor. Never an unboxed tuple or sum, as those-                        -- are not allocated.-        [StgArg]        -- Args---- | Used as a data type index for the stgSyn AST-data StgPass-  = Vanilla-  | LiftLams-  | CodeGen---- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that--- returns 'empty'.-data NoExtFieldSilent = NoExtFieldSilent-  deriving (Data, Eq, Ord)--instance Outputable NoExtFieldSilent where-  ppr _ = empty---- | Used when constructing a term with an unused extension point that should--- not appear in pretty-printed output at all.-noExtFieldSilent :: NoExtFieldSilent-noExtFieldSilent = NoExtFieldSilent--- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the--- implications on build time...---- TODO: Do we really want to the extension point type families to have a closed--- domain?-type family BinderP (pass :: StgPass)-type instance BinderP 'Vanilla = Id-type instance BinderP 'CodeGen = Id--type family XRhsClosure (pass :: StgPass)-type instance XRhsClosure 'Vanilla = NoExtFieldSilent--- | Code gen needs to track non-global free vars-type instance XRhsClosure 'CodeGen = DIdSet--type family XLet (pass :: StgPass)-type instance XLet 'Vanilla = NoExtFieldSilent-type instance XLet 'CodeGen = NoExtFieldSilent--type family XLetNoEscape (pass :: StgPass)-type instance XLetNoEscape 'Vanilla = NoExtFieldSilent-type instance XLetNoEscape 'CodeGen = NoExtFieldSilent--stgRhsArity :: StgRhs -> Int-stgRhsArity (StgRhsClosure _ _ _ bndrs _)-  = ASSERT( all isId bndrs ) length bndrs-  -- The arity never includes type parameters, but they should have gone by now-stgRhsArity (StgRhsCon _ _ _) = 0---- Note [CAF consistency]--- ~~~~~~~~~~~~~~~~~~~~~~------ `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in--- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with--- reality.------ Specifically, if the RHS mentions any Id that itself is marked--- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the--- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble--- is that `TidyPgm` computed the CAF info on the `Id` but some transformations--- have taken place since then.--topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool-topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))-  = topRhsHasCafRefs rhs-topStgBindHasCafRefs (StgTopLifted (StgRec binds))-  = any topRhsHasCafRefs (map snd binds)-topStgBindHasCafRefs StgTopStringLit{}-  = False--topRhsHasCafRefs :: GenStgRhs pass -> Bool-topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)-  = -- See Note [CAF consistency]-    isUpdatable upd || exprHasCafRefs body-topRhsHasCafRefs (StgRhsCon _ _ args)-  = any stgArgHasCafRefs args--exprHasCafRefs :: GenStgExpr pass -> Bool-exprHasCafRefs (StgApp f args)-  = stgIdHasCafRefs f || any stgArgHasCafRefs args-exprHasCafRefs StgLit{}-  = False-exprHasCafRefs (StgConApp _ args _)-  = any stgArgHasCafRefs args-exprHasCafRefs (StgOpApp _ args _)-  = any stgArgHasCafRefs args-exprHasCafRefs (StgLam _ body)-  = exprHasCafRefs body-exprHasCafRefs (StgCase scrt _ _ alts)-  = exprHasCafRefs scrt || any altHasCafRefs alts-exprHasCafRefs (StgLet _ bind body)-  = bindHasCafRefs bind || exprHasCafRefs body-exprHasCafRefs (StgLetNoEscape _ bind body)-  = bindHasCafRefs bind || exprHasCafRefs body-exprHasCafRefs (StgTick _ expr)-  = exprHasCafRefs expr--bindHasCafRefs :: GenStgBinding pass -> Bool-bindHasCafRefs (StgNonRec _ rhs)-  = rhsHasCafRefs rhs-bindHasCafRefs (StgRec binds)-  = any rhsHasCafRefs (map snd binds)--rhsHasCafRefs :: GenStgRhs pass -> Bool-rhsHasCafRefs (StgRhsClosure _ _ _ _ body)-  = exprHasCafRefs body-rhsHasCafRefs (StgRhsCon _ _ args)-  = any stgArgHasCafRefs args--altHasCafRefs :: GenStgAlt pass -> Bool-altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs--stgArgHasCafRefs :: StgArg -> Bool-stgArgHasCafRefs (StgVarArg id)-  = stgIdHasCafRefs id-stgArgHasCafRefs _-  = False--stgIdHasCafRefs :: Id -> Bool-stgIdHasCafRefs id =-  -- We are looking for occurrences of an Id that is bound at top level, and may-  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether-  -- imported or defined in this module) are GlobalIds, so the test is easy.-  isGlobalId id && mayHaveCafRefs (idCafInfo id)--{--************************************************************************-*                                                                      *-STG case alternatives-*                                                                      *-************************************************************************--Very like in @CoreSyntax@ (except no type-world stuff).--The type constructor is guaranteed not to be abstract; that is, we can see its-representation. This is important because the code generator uses it to-determine return conventions etc. But it's not trivial where there's a module-loop involved, because some versions of a type constructor might not have all-the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets-the TyCon from the constructors or literals (which are guaranteed to have the-Real McCoy) rather than from the scrutinee type.--}--type GenStgAlt pass-  = (AltCon,          -- alts: data constructor,-     [BinderP pass],  -- constructor's parameters,-     GenStgExpr pass) -- ...right-hand side.--data AltType-  = PolyAlt             -- Polymorphic (a lifted type variable)-  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)-                        -- the arity could indeed be 1 for unary unboxed tuple-                        -- or enum-like unboxed sums-  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts-  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts--{--************************************************************************-*                                                                      *-The Plain STG parameterisation-*                                                                      *-************************************************************************--This happens to be the only one we use at the moment.--}--type StgTopBinding = GenStgTopBinding 'Vanilla-type StgBinding    = GenStgBinding    'Vanilla-type StgExpr       = GenStgExpr       'Vanilla-type StgRhs        = GenStgRhs        'Vanilla-type StgAlt        = GenStgAlt        'Vanilla--type LlStgTopBinding = GenStgTopBinding 'LiftLams-type LlStgBinding    = GenStgBinding    'LiftLams-type LlStgExpr       = GenStgExpr       'LiftLams-type LlStgRhs        = GenStgRhs        'LiftLams-type LlStgAlt        = GenStgAlt        'LiftLams--type CgStgTopBinding = GenStgTopBinding 'CodeGen-type CgStgBinding    = GenStgBinding    'CodeGen-type CgStgExpr       = GenStgExpr       'CodeGen-type CgStgRhs        = GenStgRhs        'CodeGen-type CgStgAlt        = GenStgAlt        'CodeGen--{- Many passes apply a substitution, and it's very handy to have type-   synonyms to remind us whether or not the substitution has been applied.-   See CoreSyn for precedence in Core land--}--type InStgTopBinding  = StgTopBinding-type InStgBinding     = StgBinding-type InStgArg         = StgArg-type InStgExpr        = StgExpr-type InStgRhs         = StgRhs-type InStgAlt         = StgAlt-type OutStgTopBinding = StgTopBinding-type OutStgBinding    = StgBinding-type OutStgArg        = StgArg-type OutStgExpr       = StgExpr-type OutStgRhs        = StgRhs-type OutStgAlt        = StgAlt--{---************************************************************************-*                                                                      *-UpdateFlag-*                                                                      *-************************************************************************--This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.--A @ReEntrant@ closure may be entered multiple times, but should not be updated-or blackholed. An @Updatable@ closure should be updated after evaluation (and-may be blackholed during evaluation). A @SingleEntry@ closure will only be-entered once, and so need not be updated but may safely be blackholed.--}--data UpdateFlag = ReEntrant | Updatable | SingleEntry--instance Outputable UpdateFlag where-    ppr u = char $ case u of-                       ReEntrant   -> 'r'-                       Updatable   -> 'u'-                       SingleEntry -> 's'--isUpdatable :: UpdateFlag -> Bool-isUpdatable ReEntrant   = False-isUpdatable SingleEntry = False-isUpdatable Updatable   = True--{--************************************************************************-*                                                                      *-StgOp-*                                                                      *-************************************************************************--An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful-to move these around together, notably in StgOpApp and COpStmt.--}--data StgOp-  = StgPrimOp  PrimOp--  | StgPrimCallOp PrimCall--  | StgFCallOp ForeignCall Type-        -- The Type, which is obtained from the foreign import declaration-        -- itself, is needed by the stg-to-cmm pass to determine the offset to-        -- apply to unlifted boxed arguments in GHC.StgToCmm.Foreign. See Note-        -- [Unlifted boxed arguments to foreign calls]--{--************************************************************************-*                                                                      *-Pretty-printing-*                                                                      *-************************************************************************--Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he-likes terminators instead...  Ditto for case alternatives.--}--type OutputablePass pass =-  ( Outputable (XLet pass)-  , Outputable (XLetNoEscape pass)-  , Outputable (XRhsClosure pass)-  , OutputableBndr (BinderP pass)-  )--pprGenStgTopBinding-  :: OutputablePass pass => GenStgTopBinding pass -> SDoc-pprGenStgTopBinding (StgTopStringLit bndr str)-  = hang (hsep [pprBndr LetBind bndr, equals])-        4 (pprHsBytes str <> semi)-pprGenStgTopBinding (StgTopLifted bind)-  = pprGenStgBinding bind--pprGenStgBinding-  :: OutputablePass pass => GenStgBinding pass -> SDoc--pprGenStgBinding (StgNonRec bndr rhs)-  = hang (hsep [pprBndr LetBind bndr, equals])-        4 (ppr rhs <> semi)--pprGenStgBinding (StgRec pairs)-  = vcat [ text "Rec {"-         , vcat (intersperse blankLine (map ppr_bind pairs))-         , text "end Rec }" ]-  where-    ppr_bind (bndr, expr)-      = hang (hsep [pprBndr LetBind bndr, equals])-             4 (ppr expr <> semi)--pprGenStgTopBindings-  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc-pprGenStgTopBindings binds-  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)--pprStgBinding :: StgBinding -> SDoc-pprStgBinding = pprGenStgBinding--pprStgTopBindings :: [StgTopBinding] -> SDoc-pprStgTopBindings = pprGenStgTopBindings--instance Outputable StgArg where-    ppr = pprStgArg--instance OutputablePass pass => Outputable (GenStgTopBinding pass) where-    ppr = pprGenStgTopBinding--instance OutputablePass pass => Outputable (GenStgBinding pass) where-    ppr = pprGenStgBinding--instance OutputablePass pass => Outputable (GenStgExpr pass) where-    ppr = pprStgExpr--instance OutputablePass pass => Outputable (GenStgRhs pass) where-    ppr rhs = pprStgRhs rhs--pprStgArg :: StgArg -> SDoc-pprStgArg (StgVarArg var) = ppr var-pprStgArg (StgLitArg con) = ppr con--pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc--- special case-pprStgExpr (StgLit lit)     = ppr lit---- general case-pprStgExpr (StgApp func args)-  = hang (ppr func) 4 (sep (map (ppr) args))--pprStgExpr (StgConApp con args _)-  = hsep [ ppr con, brackets (interppSP args) ]--pprStgExpr (StgOpApp op args _)-  = hsep [ pprStgOp op, brackets (interppSP args)]--pprStgExpr (StgLam bndrs body)-  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))-            <+> text "->",-         pprStgExpr body ]-  where ppr_list = brackets . fsep . punctuate comma---- special case: let v = <very specific thing>---               in---               let ...---               in---               ...------ Very special!  Suspicious! (SLPJ)--{--pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))-                        expr@(StgLet _ _))-  = ($$)-      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),-                          ppr cc,-                          pp_binder_info bi,-                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),-                          ppr upd_flag, text " [",-                          interppSP args, char ']'])-            8 (sep [hsep [ppr rhs, text "} in"]]))-      (ppr expr)--}---- special case: let ... in let ...--pprStgExpr (StgLet ext bind expr@StgLet{})-  = ($$)-      (sep [hang (text "let" <+> ppr ext <+> text "{")-                2 (hsep [pprGenStgBinding bind, text "} in"])])-      (ppr expr)---- general case-pprStgExpr (StgLet ext bind expr)-  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),-           hang (text "} in ") 2 (ppr expr)]--pprStgExpr (StgLetNoEscape ext bind expr)-  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")-                2 (pprGenStgBinding bind),-           hang (text "} in ")-                2 (ppr expr)]--pprStgExpr (StgTick tickish expr)-  = sdocWithDynFlags $ \dflags ->-    if gopt Opt_SuppressTicks dflags-    then pprStgExpr expr-    else sep [ ppr tickish, pprStgExpr expr ]----- Don't indent for a single case alternative.-pprStgExpr (StgCase expr bndr alt_type [alt])-  = sep [sep [text "case",-           nest 4 (hsep [pprStgExpr expr,-             whenPprDebug (dcolon <+> ppr alt_type)]),-           text "of", pprBndr CaseBind bndr, char '{'],-           pprStgAlt False alt,-           char '}']--pprStgExpr (StgCase expr bndr alt_type alts)-  = sep [sep [text "case",-           nest 4 (hsep [pprStgExpr expr,-             whenPprDebug (dcolon <+> ppr alt_type)]),-           text "of", pprBndr CaseBind bndr, char '{'],-           nest 2 (vcat (map (pprStgAlt True) alts)),-           char '}']---pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc-pprStgAlt indent (con, params, expr)-  | indent    = hang altPattern 4 (ppr expr <> semi)-  | otherwise = sep [altPattern, ppr expr <> semi]-    where-      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])---pprStgOp :: StgOp -> SDoc-pprStgOp (StgPrimOp  op)   = ppr op-pprStgOp (StgPrimCallOp op)= ppr op-pprStgOp (StgFCallOp op _) = ppr op--instance Outputable AltType where-  ppr PolyAlt         = text "Polymorphic"-  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n-  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc-  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc--pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc--pprStgRhs (StgRhsClosure ext cc upd_flag args body)-  = sdocWithDynFlags $ \dflags ->-    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,-                if not $ gopt Opt_SuppressStgExts dflags-                  then ppr ext else empty,-                char '\\' <> ppr upd_flag, brackets (interppSP args)])-         4 (ppr body)--pprStgRhs (StgRhsCon cc con args)-  = hcat [ ppr cc,-           space, ppr con, text "! ", brackets (interppSP args)]
compiler/GHC/Stg/Unarise.hs view
@@ -194,6 +194,8 @@  {-# LANGUAGE CPP, TupleSections #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module GHC.Stg.Unarise (unarise) where  #include "HsVersions.h"
compiler/GHC/StgToCmm.hs view
@@ -26,9 +26,9 @@ import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky -import Cmm-import CmmUtils-import CLabel+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.CLabel  import GHC.Stg.Syntax import DynFlags@@ -48,7 +48,7 @@ import VarSet ( isEmptyDVarSet )  import OrdList-import MkGraph+import GHC.Cmm.Graph  import Data.IORef import Control.Monad (when,void)
compiler/GHC/StgToCmm/ArgRep.hs view
@@ -19,7 +19,7 @@  import GHC.StgToCmm.Closure ( idPrimRep ) -import SMRep            ( WordOff )+import GHC.Runtime.Layout            ( WordOff ) import Id               ( Id ) import TyCon            ( PrimRep(..), primElemRepSizeB ) import BasicTypes       ( RepArity )
compiler/GHC/StgToCmm/Bind.hs view
@@ -28,14 +28,14 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Foreign    (emitPrimCall) -import MkGraph+import GHC.Cmm.Graph import CoreSyn          ( AltCon(..), tickishIsCode )-import BlockId-import SMRep-import Cmm-import CmmInfo-import CmmUtils-import CLabel+import GHC.Cmm.BlockId+import GHC.Runtime.Layout+import GHC.Cmm+import GHC.Cmm.Info+import GHC.Cmm.Utils+import GHC.Cmm.CLabel import GHC.Stg.Syntax import CostCentre import Id@@ -105,7 +105,7 @@          -- We don't generate the static closure here, because we might         -- want to add references to static closures to it later.  The-        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,+        -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs,         -- See Note [SRTs], specifically the [FUN] optimisation.          ; let fv_details :: [(NonVoid Id, ByteOff)]@@ -198,7 +198,7 @@                  CgIdInfo         -- The info for this binding                , FCode CmmAGraph  -- A computation which will generate the                                   -- code for the binding, and return an-                                  -- assignent of the form "x = Hp - n"+                                  -- assignment of the form "x = Hp - n"                                   -- (see above)                ) @@ -622,7 +622,7 @@   -- unconditionally disabled. -- krc 1/2007    -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,-  -- because emitBlackHoleCode is called from CmmParse.+  -- because emitBlackHoleCode is called from GHC.Cmm.Parser.    let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)                          && gopt Opt_EagerBlackHoling dflags
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -19,11 +19,11 @@ import GhcPrelude  import GHC.Platform.Regs-import Cmm-import Hoopl.Block-import Hoopl.Graph-import CmmUtils-import CLabel+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Utils+import GHC.Cmm.CLabel import DynFlags import Outputable
compiler/GHC/StgToCmm/Closure.hs view
@@ -67,13 +67,13 @@ import GhcPrelude  import GHC.Stg.Syntax-import SMRep-import Cmm-import PprCmmExpr() -- For Outputable instances+import GHC.Runtime.Layout+import GHC.Cmm+import GHC.Cmm.Ppr.Expr() -- For Outputable instances  import CostCentre-import BlockId-import CLabel+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel import Id import IdInfo import DataCon
compiler/GHC/StgToCmm/DataCon.hs view
@@ -29,11 +29,11 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure -import CmmExpr-import CmmUtils-import CLabel-import MkGraph-import SMRep+import GHC.Cmm.Expr+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Cmm.Graph+import GHC.Runtime.Layout import CostCentre import Module import DataCon
compiler/GHC/StgToCmm/Env.hs view
@@ -31,14 +31,14 @@ import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure -import CLabel+import GHC.Cmm.CLabel -import BlockId-import CmmExpr-import CmmUtils+import GHC.Cmm.BlockId+import GHC.Cmm.Expr+import GHC.Cmm.Utils import DynFlags import Id-import MkGraph+import GHC.Cmm.Graph import Name import Outputable import GHC.Stg.Syntax
compiler/GHC/StgToCmm/Expr.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: expressions@@ -30,10 +32,10 @@  import GHC.Stg.Syntax -import MkGraph-import BlockId-import Cmm hiding ( succ )-import CmmInfo+import GHC.Cmm.Graph+import GHC.Cmm.BlockId+import GHC.Cmm hiding ( succ )+import GHC.Cmm.Info import CoreSyn import DataCon import DynFlags         ( mAX_PTR_TAG )@@ -301,75 +303,7 @@ ------------------------------------- cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind -cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts-  | isEnumerationTyCon tycon -- Note [case on bool]-  = do { tag_expr <- do_enum_primop op args--       -- If the binder is not dead, convert the tag to a constructor-       -- and assign it. See Note [Dead-binder optimisation]-       ; unless (isDeadBinder bndr) $ do-            { dflags <- getDynFlags-            ; tmp_reg <- bindArgToReg (NonVoid bndr)-            ; emitAssign (CmmLocal tmp_reg)-                         (tagToClosure dflags tycon tag_expr) }--       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)-                                              (NonVoid bndr) alts-                                 -- See Note [GC for conditionals]-       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)-       ; return AssignedDirectly-       }-  where-    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr-    do_enum_primop TagToEnumOp [arg]  -- No code!-      = getArgAmode (NonVoid arg)-    do_enum_primop primop args-      = do dflags <- getDynFlags-           tmp <- newTemp (bWord dflags)-           cgPrimOp [tmp] primop args-           return (CmmReg (CmmLocal tmp))- {--Note [case on bool]-~~~~~~~~~~~~~~~~~~~-This special case handles code like--  case a <# b of-    True ->-    False ->---->  case tagToEnum# (a <$# b) of-        True -> .. ; False -> ...----> case (a <$# b) of r ->-    case tagToEnum# r of-        True -> .. ; False -> ...--If we let the ordinary case code handle it, we'll get something like-- tmp1 = a < b- tmp2 = Bool_closure_tbl[tmp1]- if (tmp2 & 7 != 0) then ... // normal tagged case--but this junk won't optimise away.  What we really want is just an-inline comparison:-- if (a < b) then ...--So we add a special case to generate-- tmp1 = a < b- if (tmp1 == 0) then ...--and later optimisations will further improve this.--Now that #6135 has been resolved it should be possible to remove that-special case. The idea behind this special case and pre-6135 implementation-of Bool-returning primops was that tagToEnum# was added implicitly in the-codegen and then optimized away. Now the call to tagToEnum# is explicit-in the source code, which allows to optimize it away at the earlier stages-of compilation (i.e. at the Core level).- Note [Scrutinising VoidRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this STG code:
compiler/GHC/StgToCmm/ExtCode.hs view
@@ -42,11 +42,11 @@ import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) -import Cmm-import CLabel-import MkGraph+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.Graph -import BlockId+import GHC.Cmm.BlockId import DynFlags import FastString import Module@@ -102,7 +102,7 @@                                    return (d, dflags))  --- | Takes the variable decarations and imports from the monad+-- | Takes the variable declarations and imports from the monad --      and makes an environment, which is looped back into the computation. --      In this way, we can have embedded declarations that scope over the whole --      procedure, and imports that scope over the entire module.
compiler/GHC/StgToCmm/Foreign.hs view
@@ -9,7 +9,7 @@ module GHC.StgToCmm.Foreign (   cgForeignCall,   emitPrimCall, emitCCall,-  emitForeignCall,     -- For CmmParse+  emitForeignCall,   emitSaveThreadState,   saveThreadState,   emitLoadThreadState,@@ -28,14 +28,14 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Layout -import BlockId (newBlockId)-import Cmm-import CmmUtils-import MkGraph+import GHC.Cmm.BlockId (newBlockId)+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Graph import Type import GHC.Types.RepType-import CLabel-import SMRep+import GHC.Cmm.CLabel+import GHC.Runtime.Layout import ForeignCall import DynFlags import Maybes@@ -202,7 +202,7 @@ emitPrimCall res op args   = void $ emitForeignCall PlayRisky res (PrimTarget op) args --- alternative entry point, used by CmmParse+-- alternative entry point, used by GHC.Cmm.Parser emitForeignCall         :: Safety         -> [CmmFormal]          -- where to put the results@@ -257,9 +257,9 @@ -- Note [Register Parameter Passing]). -- -- However, we can't pattern-match on the expression here, because--- this is used in a loop by CmmParse, and testing the expression+-- this is used in a loop by GHC.Cmm.Parser, and testing the expression -- results in a black hole.  So we always create a temporary, and rely--- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code+-- on GHC.Cmm.Sink to clean it up later.  (Yuck, ToDo).  The generated code -- ends up being the same, at least for the RTS .cmm code. -- maybe_assign_temp :: CmmExpr -> FCode CmmExpr
compiler/GHC/StgToCmm/Heap.hs view
@@ -6,6 +6,8 @@ -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module GHC.StgToCmm.Heap (         getVirtHp, setVirtHp, setRealHp,         getHpRelOffset,@@ -23,7 +25,7 @@ import GhcPrelude hiding ((<*>))  import GHC.Stg.Syntax-import CLabel+import GHC.Cmm.CLabel import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad@@ -32,13 +34,13 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Env -import MkGraph+import GHC.Cmm.Graph -import Hoopl.Label-import SMRep-import BlockId-import Cmm-import CmmUtils+import GHC.Cmm.Dataflow.Label+import GHC.Runtime.Layout+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils import CostCentre import IdInfo( CafInfo(..), mayHaveCafRefs ) import Id ( Id )@@ -337,7 +339,7 @@                  Just (_, ArgGen _) -> False                  _otherwise         -> True --- | lower-level version for CmmParse+-- | lower-level version for GHC.Cmm.Parser entryHeapCheck' :: Bool           -- is a known function pattern                 -> CmmExpr        -- expression for the closure pointer                 -> Int            -- Arity -- not same as len args b/c of voids
compiler/GHC/StgToCmm/Hpc.hs view
@@ -12,11 +12,11 @@  import GHC.StgToCmm.Monad -import MkGraph-import CmmExpr-import CLabel+import GHC.Cmm.Graph+import GHC.Cmm.Expr+import GHC.Cmm.CLabel import Module-import CmmUtils+import GHC.Cmm.Utils import GHC.StgToCmm.Utils import HscTypes import DynFlags
compiler/GHC/StgToCmm/Layout.hs view
@@ -41,13 +41,13 @@ import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils -import MkGraph-import SMRep-import BlockId-import Cmm-import CmmUtils-import CmmInfo-import CLabel+import GHC.Cmm.Graph+import GHC.Runtime.Layout+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Info+import GHC.Cmm.CLabel import GHC.Stg.Syntax import Id import TyCon             ( PrimRep(..), primRepSizeB )
compiler/GHC/StgToCmm/Monad.hs view
@@ -61,14 +61,14 @@  import GhcPrelude hiding( sequence, succ ) -import Cmm+import GHC.Cmm import GHC.StgToCmm.Closure import DynFlags-import Hoopl.Collections-import MkGraph-import BlockId-import CLabel-import SMRep+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Graph as CmmGraph+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Runtime.Layout import Module import Id import VarEnv@@ -369,7 +369,7 @@ -- Add code blocks from the latter to the former -- (The cgs_stmts will often be empty, but not always; see codeOnly) s1 `addCodeBlocksFrom` s2-  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,+  = s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }  @@ -715,7 +715,7 @@ emit :: CmmAGraph -> FCode () emit ag   = do  { state <- getState-        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }+        ; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } }  emitDecl :: CmmDecl -> FCode () emitDecl decl@@ -743,7 +743,7 @@         -- do layout   = do  { dflags <- getDynFlags         ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args-              graph' = entry MkGraph.<*> graph+              graph' = entry CmmGraph.<*> graph         ; emitProc mb_info lbl live (graph', tscope) offset True         } emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
compiler/GHC/StgToCmm/Prim.hs view
@@ -7,2159 +7,2144 @@ {-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-} #endif ----------------------------------------------------------------------------------- Stg to C--: primitive operations------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module GHC.StgToCmm.Prim (-   cgOpApp,-   cgPrimOp, -- internal(ish), used by cgCase to get code for a-             -- comparison without also turning it into a Bool.-   shouldInlinePrimOp- ) where--#include "HsVersions.h"--import GhcPrelude hiding ((<*>))--import GHC.StgToCmm.Layout-import GHC.StgToCmm.Foreign-import GHC.StgToCmm.Env-import GHC.StgToCmm.Monad-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Ticky-import GHC.StgToCmm.Heap-import GHC.StgToCmm.Prof ( costCentreFrom )--import DynFlags-import GHC.Platform-import BasicTypes-import BlockId-import MkGraph-import GHC.Stg.Syntax-import Cmm-import Module   ( rtsUnitId )-import Type     ( Type, tyConAppTyCon )-import TyCon-import CLabel-import CmmUtils-import PrimOp-import SMRep-import FastString-import Outputable-import Util-import Data.Maybe--import Data.Bits ((.&.), bit)-import Control.Monad (liftM, when, unless)-----------------------------------------------------------------------------      Primitive operations and foreign calls---------------------------------------------------------------------------{- Note [Foreign call results]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~-A foreign call always returns an unboxed tuple of results, one-of which is the state token.  This seems to happen even for pure-calls.--Even if we returned a single result for pure calls, it'd still be-right to wrap it in a singleton unboxed tuple, because the result-might be a Haskell closure pointer, we don't want to evaluate it. -}-------------------------------------cgOpApp :: StgOp        -- The op-        -> [StgArg]     -- Arguments-        -> Type         -- Result type (always an unboxed tuple)-        -> FCode ReturnKind---- Foreign calls-cgOpApp (StgFCallOp fcall ty) stg_args res_ty-  = cgForeignCall fcall ty stg_args res_ty-      -- Note [Foreign call results]---- tagToEnum# is special: we need to pull the constructor--- out of the table, and perform an appropriate return.--cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty-  = ASSERT(isEnumerationTyCon tycon)-    do  { dflags <- getDynFlags-        ; args' <- getNonVoidArgAmodes [arg]-        ; let amode = case args' of [amode] -> amode-                                    _ -> panic "TagToEnumOp had void arg"-        ; emitReturn [tagToClosure dflags tycon amode] }-   where-          -- If you're reading this code in the attempt to figure-          -- out why the compiler panic'ed here, it is probably because-          -- you used tagToEnum# in a non-monomorphic setting, e.g.,-          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#-          -- That won't work.-        tycon = tyConAppTyCon res_ty--cgOpApp (StgPrimOp primop) args res_ty = do-    dflags <- getDynFlags-    cmm_args <- getNonVoidArgAmodes args-    case emitPrimOp dflags primop cmm_args of-        Nothing -> do  -- out-of-line-          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))-          emitCall (NativeNodeCall, NativeReturn) fun cmm_args--        Just f  -- inline-          | ReturnsPrim VoidRep <- result_info-          -> do f []-                emitReturn []--          | ReturnsPrim rep <- result_info-          -> do dflags <- getDynFlags-                res <- newTemp (primRepCmmType dflags rep)-                f [res]-                emitReturn [CmmReg (CmmLocal res)]--          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon-          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty-                f regs-                emitReturn (map (CmmReg . CmmLocal) regs)--          | otherwise -> panic "cgPrimop"-          where-             result_info = getPrimOpResultInfo primop--cgOpApp (StgPrimCallOp primcall) args _res_ty-  = do  { cmm_args <- getNonVoidArgAmodes args-        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))-        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }---- | Interpret the argument as an unsigned value, assuming the value--- is given in two-complement form in the given width.------ Example: @asUnsigned W64 (-1)@ is 18446744073709551615.------ This function is used to work around the fact that many array--- primops take Int# arguments, but we interpret them as unsigned--- quantities in the code gen. This means that we have to be careful--- every time we work on e.g. a CmmInt literal that corresponds to the--- array size, as it might contain a negative Integer value if the--- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#--- literal.-asUnsigned :: Width -> Integer -> Integer-asUnsigned w n = n .&. (bit (widthInBits w) - 1)------------------------------------------------------cgPrimOp   :: [LocalReg]        -- where to put the results-           -> PrimOp            -- the op-           -> [StgArg]          -- arguments-           -> FCode ()--cgPrimOp results op args = do-  dflags <- getDynFlags-  arg_exprs <- getNonVoidArgAmodes args-  case emitPrimOp dflags op arg_exprs of-    Nothing -> panic "External prim op"-    Just f -> f results------------------------------------------------------------------------------      Emitting code for a primop---------------------------------------------------------------------------shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool-shouldInlinePrimOp dflags op args = isJust $ emitPrimOp dflags op args---- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use--- ByteOff (or some other fixed width signed type) to represent--- array sizes or indices. This means that these will overflow for--- large enough sizes.---- TODO: Several primops, such as 'copyArray#', only have an inline--- implementation (below) but could possibly have both an inline--- implementation and an out-of-line implementation, just like--- 'newArray#'. This would lower the amount of code generated,--- hopefully without a performance impact (needs to be measured).---- | The big function handling all the primops. The 'OpDest' function type--- abstracts over a few common cases, and the "most manual" fallback.------ In the simple case, there is just one implementation, and we emit that.------ In more complex cases, there is a foreign call (out of line) fallback. This--- might happen e.g. if there's enough static information, such as statically--- know arguments.-dispatchPrimop-  :: DynFlags-  -> PrimOp            -- ^ The primop-  -> [CmmExpr]         -- ^ The primop arguments-  -> OpDest-dispatchPrimop dflags = \case-  NewByteArrayOp_Char -> \case-    [(CmmLit (CmmInt n w))]-      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone  $ \ [res] -> doNewByteArrayOp res (fromInteger n)-    _ -> OpDest_External--  NewArrayOp -> \case-    [(CmmLit (CmmInt n w)), init]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel-        [ (mkIntExpr dflags (fromInteger n),-           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)-        , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),-           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)-        ]-        (fromInteger n) init-    _ -> OpDest_External--  CopyArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      OpDest_AllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> OpDest_External--  CopyMutableArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      OpDest_AllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> OpDest_External--  CopyArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      OpDest_AllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> OpDest_External--  CopyMutableArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      OpDest_AllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> OpDest_External--  CloneArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  CloneMutableArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  FreezeArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  ThawArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  NewSmallArrayOp -> \case-    [(CmmLit (CmmInt n w)), init]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] ->-        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel-        [ (mkIntExpr dflags (fromInteger n),-           fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-        ]-        (fromInteger n) init-    _ -> OpDest_External--  CopySmallArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      OpDest_AllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)-    _ -> OpDest_External--  CopySmallMutableArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      OpDest_AllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> OpDest_External--  CloneSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  CloneSmallMutableArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  FreezeSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External--  ThawSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> OpDest_AllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> OpDest_External---- First we handle various awkward cases specially.--  ParOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    -- for now, just implement this in a C function-    -- later, we might want to inline it.-    emitCCall-        [(res,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr, AddrHint), (arg,AddrHint)]--  SparkOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    -- returns the value of arg in res.  We're going to therefore-    -- refer to arg twice (once to pass to newSpark(), and once to-    -- assign to res), so put it in a temporary.-    tmp <- assignTemp arg-    tmp2 <- newTemp (bWord dflags)-    emitCCall-        [(tmp2,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]-    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))--  GetCCSOfOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    let-      val-       | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)-       | otherwise                      = CmmLit (zeroCLit dflags)-    emitAssign (CmmLocal res) val--  GetCurrentCCSOp -> \[_] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) cccsExpr--  MyThreadIdOp -> \[] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) currentTSOExpr--  ReadMutVarOp -> \[mutv] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))--  WriteMutVarOp -> \[mutv, var] -> OpDest_AllDone $ \res@[] -> do-    old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)-    emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))--    -- Without this write barrier, other CPUs may see this pointer before-    -- the writes for the closure it points to have occurred.-    -- Note that this also must come after we read the old value to ensure-    -- that the read of old_val comes before another core's write to the-    -- MutVar's value.-    emitPrimCall res MO_WriteBarrier []-    emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var-    emitCCall-            [{-no results-}]-            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))-            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]----  #define sizzeofByteArrayzh(r,a) \---     r = ((StgArrBytes *)(a))->bytes-  SizeofByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))----  #define sizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-  SizeofMutableByteArrayOp -> dispatchPrimop dflags SizeofByteArrayOp----  #define getSizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-  GetSizeofMutableByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))-----  #define touchzh(o)                  /* nothing */-  TouchOp -> \args@[_] -> OpDest_AllDone $ \res@[] -> do-    emitPrimCall res MO_Touch args----  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)-  ByteArrayContents_Char -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))----  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)-  StableNameToIntOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))--  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])----  #define addrToHValuezh(r,a) r=(P_)a-  AddrToAnyOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) arg----  #define hvalueToAddrzh(r, a) r=(W_)a-  AnyToAddrOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) arg--{- Freezing arrays-of-ptrs requires changing an info table, for the-   benefit of the generational collector.  It needs to scavenge mutable-   objects, even if they are in old space.  When they become immutable,-   they can be removed from this scavenge list.  -}----  #define unsafeFreezzeArrayzh(r,a)---      {---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);---        r = a;---      }-  UnsafeFreezeArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]-  UnsafeFreezeArrayArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]-  UnsafeFreezeSmallArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]----  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)-  UnsafeFreezeByteArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emitAssign (CmmLocal res) arg---- Reading/writing pointer arrays--  ReadArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  IndexArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  WriteArrayOp -> \[obj, ix, v] -> OpDest_AllDone $ \[] -> do-    doWritePtrArrayOp obj ix v--  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadPtrArrayOp res obj ix-  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do-    doWritePtrArrayOp obj ix v--  ReadSmallArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadSmallPtrArrayOp res obj ix-  IndexSmallArrayOp -> \[obj, ix] -> OpDest_AllDone $ \[res] -> do-    doReadSmallPtrArrayOp res obj ix-  WriteSmallArrayOp -> \[obj,ix,v] -> OpDest_AllDone $ \[] -> do-    doWriteSmallPtrArrayOp obj ix v---- Getting the size of pointer arrays--  SizeofArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg-      (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))-        (bWord dflags))-  SizeofMutableArrayOp -> dispatchPrimop dflags SizeofArrayOp-  SizeofArrayArrayOp -> dispatchPrimop dflags SizeofArrayOp-  SizeofMutableArrayArrayOp -> dispatchPrimop dflags SizeofArrayOp-  SizeofSmallArrayOp -> \[arg] -> OpDest_AllDone $ \[res] -> do-    emit $ mkAssign (CmmLocal res)-     (cmmLoadIndexW dflags arg-     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))-        (bWord dflags))--  SizeofSmallMutableArrayOp -> dispatchPrimop dflags SizeofSmallArrayOp-  GetSizeofSmallMutableArrayOp -> dispatchPrimop dflags SizeofSmallArrayOp---- IndexXXXoffAddr--  IndexOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args-  IndexOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-  IndexOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  IndexOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  IndexOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  IndexOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing f32 res args-  IndexOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing f64 res args-  IndexOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  IndexOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args-  IndexOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args-  IndexOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args-  IndexOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args-  IndexOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args-  IndexOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args-  IndexOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-  IndexOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args---- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.--  ReadOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args-  ReadOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-  ReadOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  ReadOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  ReadOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  ReadOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing f32 res args-  ReadOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing f64 res args-  ReadOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing (bWord dflags) res args-  ReadOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args-  ReadOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args-  ReadOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args-  ReadOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args-  ReadOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args-  ReadOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args-  ReadOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args-  ReadOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args---- IndexXXXArray--  IndexByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args-  IndexByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args-  IndexByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  IndexByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  IndexByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  IndexByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing f32 res args-  IndexByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing f64 res args-  IndexByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  IndexByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args-  IndexByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args-  IndexByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args-  IndexByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args-  IndexByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args-  IndexByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args-  IndexByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args-  IndexByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args---- ReadXXXArray, identical to IndexXXXArray.--  ReadByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args-  ReadByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args-  ReadByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  ReadByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  ReadByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  ReadByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing f32 res args-  ReadByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing f64 res args-  ReadByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing (bWord dflags) res args-  ReadByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args-  ReadByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args-  ReadByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args-  ReadByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args-  ReadByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args-  ReadByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args-  ReadByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args-  ReadByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args---- IndexWord8ArrayAsXXX--  IndexByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args-  IndexByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-  IndexByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  IndexByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  IndexByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  IndexByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing f32 b8 res args-  IndexByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing f64 b8 res args-  IndexByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  IndexByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args-  IndexByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args-  IndexByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args-  IndexByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args-  IndexByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-  IndexByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args---- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX--  ReadByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args-  ReadByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-  ReadByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  ReadByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  ReadByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  ReadByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing f32 b8 res args-  ReadByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing f64 b8 res args-  ReadByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args-  ReadByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args-  ReadByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args-  ReadByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args-  ReadByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args-  ReadByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args-  ReadByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args---- WriteXXXoffAddr--  WriteOffAddrOp_Char -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-  WriteOffAddrOp_WideChar -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-  WriteOffAddrOp_Int -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args-  WriteOffAddrOp_Word -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args-  WriteOffAddrOp_Addr -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args-  WriteOffAddrOp_Float -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing f32 res args-  WriteOffAddrOp_Double -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing f64 res args-  WriteOffAddrOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing (bWord dflags) res args-  WriteOffAddrOp_Int8 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-  WriteOffAddrOp_Int16 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args-  WriteOffAddrOp_Int32 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-  WriteOffAddrOp_Int64 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing b64 res args-  WriteOffAddrOp_Word8 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args-  WriteOffAddrOp_Word16 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args-  WriteOffAddrOp_Word32 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args-  WriteOffAddrOp_Word64 -> \args -> OpDest_AllDone $ \res -> do-    doWriteOffAddrOp Nothing b64 res args---- WriteXXXArray--  WriteByteArrayOp_Char -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-  WriteByteArrayOp_WideChar -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-  WriteByteArrayOp_Int -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args-  WriteByteArrayOp_Word -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args-  WriteByteArrayOp_Addr -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args-  WriteByteArrayOp_Float -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing f32 res args-  WriteByteArrayOp_Double -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing f64 res args-  WriteByteArrayOp_StablePtr -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing (bWord dflags) res args-  WriteByteArrayOp_Int8 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-  WriteByteArrayOp_Int16 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args-  WriteByteArrayOp_Int32 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-  WriteByteArrayOp_Int64 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b64 res args-  WriteByteArrayOp_Word8 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args-  WriteByteArrayOp_Word16 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args-  WriteByteArrayOp_Word32 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args-  WriteByteArrayOp_Word64 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b64 res args---- WriteInt8ArrayAsXXX--  WriteByteArrayOp_Word8AsChar -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args-  WriteByteArrayOp_Word8AsWideChar -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-  WriteByteArrayOp_Word8AsInt -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsAddr -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsFloat -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsDouble -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsStablePtr -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsInt16 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args-  WriteByteArrayOp_Word8AsInt32 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-  WriteByteArrayOp_Word8AsInt64 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord16 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args-  WriteByteArrayOp_Word8AsWord32 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args-  WriteByteArrayOp_Word8AsWord64 -> \args -> OpDest_AllDone $ \res -> do-    doWriteByteArrayOp Nothing b8 res args---- Copying and setting byte arrays-  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do-    doCopyByteArrayOp src src_off dst dst_off n-  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do-    doCopyMutableByteArrayOp src src_off dst dst_off n-  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> OpDest_AllDone $ \[] -> do-    doCopyByteArrayToAddrOp src src_off dst n-  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> OpDest_AllDone $ \[] -> do-    doCopyMutableByteArrayToAddrOp src src_off dst n-  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> OpDest_AllDone $ \[] -> do-    doCopyAddrToByteArrayOp src dst dst_off n-  SetByteArrayOp -> \[ba,off,len,c] -> OpDest_AllDone $ \[] -> do-    doSetByteArrayOp ba off len c---- Comparing byte arrays-  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> OpDest_AllDone $ \[res] -> do-    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n--  BSwap16Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBSwapCall res w W16-  BSwap32Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBSwapCall res w W32-  BSwap64Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBSwapCall res w W64-  BSwapOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBSwapCall res w (wordWidth dflags)--  BRev8Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBRevCall res w W8-  BRev16Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBRevCall res w W16-  BRev32Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBRevCall res w W32-  BRev64Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBRevCall res w W64-  BRevOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitBRevCall res w (wordWidth dflags)---- Population count-  PopCnt8Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPopCntCall res w W8-  PopCnt16Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPopCntCall res w W16-  PopCnt32Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPopCntCall res w W32-  PopCnt64Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPopCntCall res w W64-  PopCntOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPopCntCall res w (wordWidth dflags)---- Parallel bit deposit-  Pdep8Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPdepCall res src mask W8-  Pdep16Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPdepCall res src mask W16-  Pdep32Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPdepCall res src mask W32-  Pdep64Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPdepCall res src mask W64-  PdepOp -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPdepCall res src mask (wordWidth dflags)---- Parallel bit extract-  Pext8Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPextCall res src mask W8-  Pext16Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPextCall res src mask W16-  Pext32Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPextCall res src mask W32-  Pext64Op -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPextCall res src mask W64-  PextOp -> \[src, mask] -> OpDest_AllDone $ \[res] -> do-    emitPextCall res src mask (wordWidth dflags)---- count leading zeros-  Clz8Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitClzCall res w W8-  Clz16Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitClzCall res w W16-  Clz32Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitClzCall res w W32-  Clz64Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitClzCall res w W64-  ClzOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitClzCall res w (wordWidth dflags)---- count trailing zeros-  Ctz8Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitCtzCall res w W8-  Ctz16Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitCtzCall res w W16-  Ctz32Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitCtzCall res w W32-  Ctz64Op -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitCtzCall res w W64-  CtzOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitCtzCall res w (wordWidth dflags)---- Unsigned int to floating point conversions-  Word2FloatOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPrimCall [res] (MO_UF_Conv W32) [w]-  Word2DoubleOp -> \[w] -> OpDest_AllDone $ \[res] -> do-    emitPrimCall [res] (MO_UF_Conv W64) [w]---- SIMD primops-  (VecBroadcastOp vcat n w) -> \[e] -> OpDest_AllDone $ \[res] -> do-    checkVecCompatibility dflags vcat n w-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res-   where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecPackOp vcat n w) -> \es -> OpDest_AllDone $ \[res] -> do-    checkVecCompatibility dflags vcat n w-    when (es `lengthIsNot` n) $-        panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res-   where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecUnpackOp vcat n w) -> \[arg] -> OpDest_AllDone $ \res -> do-    checkVecCompatibility dflags vcat n w-    when (res `lengthIsNot` n) $-        panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecInsertOp vcat n w) -> \[v,e,i] -> OpDest_AllDone $ \[res] -> do-    checkVecCompatibility dflags vcat n w-    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecReadByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecWriteByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecReadOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecWriteOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexScalarByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecReadScalarByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecWriteScalarByteArrayOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecIndexScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecReadScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecWriteScalarOffAddrOp vcat n w) -> \args -> OpDest_AllDone $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecCmmCat vcat w---- Prefetch-  PrefetchByteArrayOp3         -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchByteArrayOp 3  args-  PrefetchMutableByteArrayOp3  -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchMutableByteArrayOp 3  args-  PrefetchAddrOp3              -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchAddrOp  3  args-  PrefetchValueOp3             -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchValueOp 3 args--  PrefetchByteArrayOp2         -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchByteArrayOp 2  args-  PrefetchMutableByteArrayOp2  -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchMutableByteArrayOp 2  args-  PrefetchAddrOp2              -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchAddrOp 2  args-  PrefetchValueOp2             -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchValueOp 2 args-  PrefetchByteArrayOp1         -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchByteArrayOp 1  args-  PrefetchMutableByteArrayOp1  -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchMutableByteArrayOp 1  args-  PrefetchAddrOp1              -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchAddrOp 1  args-  PrefetchValueOp1             -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchValueOp 1 args--  PrefetchByteArrayOp0         -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchByteArrayOp 0  args-  PrefetchMutableByteArrayOp0  -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchMutableByteArrayOp 0  args-  PrefetchAddrOp0              -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchAddrOp 0  args-  PrefetchValueOp0             -> \args -> OpDest_AllDone $ \[] -> do-    doPrefetchValueOp 0 args---- Atomic read-modify-write-  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do-    doAtomicRMW res AMO_Add mba ix (bWord dflags) n-  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do-    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n-  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do-    doAtomicRMW res AMO_And mba ix (bWord dflags) n-  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do-    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n-  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do-    doAtomicRMW res AMO_Or mba ix (bWord dflags) n-  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> OpDest_AllDone $ \[res] -> do-    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n-  AtomicReadByteArrayOp_Int -> \[mba, ix] -> OpDest_AllDone $ \[res] -> do-    doAtomicReadByteArray res mba ix (bWord dflags)-  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> OpDest_AllDone $ \[] -> do-    doAtomicWriteByteArray mba ix (bWord dflags) val-  CasByteArrayOp_Int -> \[mba, ix, old, new] -> OpDest_AllDone $ \[res] -> do-    doCasByteArray res mba ix (bWord dflags) old new---- The rest just translate straightforwardly--  Int2WordOp      -> \_ -> OpDest_Nop-  Word2IntOp      -> \_ -> OpDest_Nop-  Int2AddrOp      -> \_ -> OpDest_Nop-  Addr2IntOp      -> \_ -> OpDest_Nop-  ChrOp           -> \_ -> OpDest_Nop  -- Int# and Char# are rep'd the same-  OrdOp           -> \_ -> OpDest_Nop--  Narrow8IntOp   -> \_ -> OpDest_Narrow (MO_SS_Conv, W8)-  Narrow16IntOp  -> \_ -> OpDest_Narrow (MO_SS_Conv, W16)-  Narrow32IntOp  -> \_ -> OpDest_Narrow (MO_SS_Conv, W32)-  Narrow8WordOp  -> \_ -> OpDest_Narrow (MO_UU_Conv, W8)-  Narrow16WordOp -> \_ -> OpDest_Narrow (MO_UU_Conv, W16)-  Narrow32WordOp -> \_ -> OpDest_Narrow (MO_UU_Conv, W32)--  DoublePowerOp  -> \_ -> OpDest_Callish MO_F64_Pwr-  DoubleSinOp    -> \_ -> OpDest_Callish MO_F64_Sin-  DoubleCosOp    -> \_ -> OpDest_Callish MO_F64_Cos-  DoubleTanOp    -> \_ -> OpDest_Callish MO_F64_Tan-  DoubleSinhOp   -> \_ -> OpDest_Callish MO_F64_Sinh-  DoubleCoshOp   -> \_ -> OpDest_Callish MO_F64_Cosh-  DoubleTanhOp   -> \_ -> OpDest_Callish MO_F64_Tanh-  DoubleAsinOp   -> \_ -> OpDest_Callish MO_F64_Asin-  DoubleAcosOp   -> \_ -> OpDest_Callish MO_F64_Acos-  DoubleAtanOp   -> \_ -> OpDest_Callish MO_F64_Atan-  DoubleAsinhOp  -> \_ -> OpDest_Callish MO_F64_Asinh-  DoubleAcoshOp  -> \_ -> OpDest_Callish MO_F64_Acosh-  DoubleAtanhOp  -> \_ -> OpDest_Callish MO_F64_Atanh-  DoubleLogOp    -> \_ -> OpDest_Callish MO_F64_Log-  DoubleLog1POp  -> \_ -> OpDest_Callish MO_F64_Log1P-  DoubleExpOp    -> \_ -> OpDest_Callish MO_F64_Exp-  DoubleExpM1Op  -> \_ -> OpDest_Callish MO_F64_ExpM1-  DoubleSqrtOp   -> \_ -> OpDest_Callish MO_F64_Sqrt--  FloatPowerOp   -> \_ -> OpDest_Callish MO_F32_Pwr-  FloatSinOp     -> \_ -> OpDest_Callish MO_F32_Sin-  FloatCosOp     -> \_ -> OpDest_Callish MO_F32_Cos-  FloatTanOp     -> \_ -> OpDest_Callish MO_F32_Tan-  FloatSinhOp    -> \_ -> OpDest_Callish MO_F32_Sinh-  FloatCoshOp    -> \_ -> OpDest_Callish MO_F32_Cosh-  FloatTanhOp    -> \_ -> OpDest_Callish MO_F32_Tanh-  FloatAsinOp    -> \_ -> OpDest_Callish MO_F32_Asin-  FloatAcosOp    -> \_ -> OpDest_Callish MO_F32_Acos-  FloatAtanOp    -> \_ -> OpDest_Callish MO_F32_Atan-  FloatAsinhOp   -> \_ -> OpDest_Callish MO_F32_Asinh-  FloatAcoshOp   -> \_ -> OpDest_Callish MO_F32_Acosh-  FloatAtanhOp   -> \_ -> OpDest_Callish MO_F32_Atanh-  FloatLogOp     -> \_ -> OpDest_Callish MO_F32_Log-  FloatLog1POp   -> \_ -> OpDest_Callish MO_F32_Log1P-  FloatExpOp     -> \_ -> OpDest_Callish MO_F32_Exp-  FloatExpM1Op   -> \_ -> OpDest_Callish MO_F32_ExpM1-  FloatSqrtOp    -> \_ -> OpDest_Callish MO_F32_Sqrt---- Native word signless ops--  IntAddOp       -> \_ -> OpDest_Translate (mo_wordAdd dflags)-  IntSubOp       -> \_ -> OpDest_Translate (mo_wordSub dflags)-  WordAddOp      -> \_ -> OpDest_Translate (mo_wordAdd dflags)-  WordSubOp      -> \_ -> OpDest_Translate (mo_wordSub dflags)-  AddrAddOp      -> \_ -> OpDest_Translate (mo_wordAdd dflags)-  AddrSubOp      -> \_ -> OpDest_Translate (mo_wordSub dflags)--  IntEqOp        -> \_ -> OpDest_Translate (mo_wordEq dflags)-  IntNeOp        -> \_ -> OpDest_Translate (mo_wordNe dflags)-  WordEqOp       -> \_ -> OpDest_Translate (mo_wordEq dflags)-  WordNeOp       -> \_ -> OpDest_Translate (mo_wordNe dflags)-  AddrEqOp       -> \_ -> OpDest_Translate (mo_wordEq dflags)-  AddrNeOp       -> \_ -> OpDest_Translate (mo_wordNe dflags)--  AndOp          -> \_ -> OpDest_Translate (mo_wordAnd dflags)-  OrOp           -> \_ -> OpDest_Translate (mo_wordOr dflags)-  XorOp          -> \_ -> OpDest_Translate (mo_wordXor dflags)-  NotOp          -> \_ -> OpDest_Translate (mo_wordNot dflags)-  SllOp          -> \_ -> OpDest_Translate (mo_wordShl dflags)-  SrlOp          -> \_ -> OpDest_Translate (mo_wordUShr dflags)--  AddrRemOp      -> \_ -> OpDest_Translate (mo_wordURem dflags)---- Native word signed ops--  IntMulOp        -> \_ -> OpDest_Translate (mo_wordMul dflags)-  IntMulMayOfloOp -> \_ -> OpDest_Translate (MO_S_MulMayOflo (wordWidth dflags))-  IntQuotOp       -> \_ -> OpDest_Translate (mo_wordSQuot dflags)-  IntRemOp        -> \_ -> OpDest_Translate (mo_wordSRem dflags)-  IntNegOp        -> \_ -> OpDest_Translate (mo_wordSNeg dflags)--  IntGeOp        -> \_ -> OpDest_Translate (mo_wordSGe dflags)-  IntLeOp        -> \_ -> OpDest_Translate (mo_wordSLe dflags)-  IntGtOp        -> \_ -> OpDest_Translate (mo_wordSGt dflags)-  IntLtOp        -> \_ -> OpDest_Translate (mo_wordSLt dflags)--  AndIOp         -> \_ -> OpDest_Translate (mo_wordAnd dflags)-  OrIOp          -> \_ -> OpDest_Translate (mo_wordOr dflags)-  XorIOp         -> \_ -> OpDest_Translate (mo_wordXor dflags)-  NotIOp         -> \_ -> OpDest_Translate (mo_wordNot dflags)-  ISllOp         -> \_ -> OpDest_Translate (mo_wordShl dflags)-  ISraOp         -> \_ -> OpDest_Translate (mo_wordSShr dflags)-  ISrlOp         -> \_ -> OpDest_Translate (mo_wordUShr dflags)---- Native word unsigned ops--  WordGeOp       -> \_ -> OpDest_Translate (mo_wordUGe dflags)-  WordLeOp       -> \_ -> OpDest_Translate (mo_wordULe dflags)-  WordGtOp       -> \_ -> OpDest_Translate (mo_wordUGt dflags)-  WordLtOp       -> \_ -> OpDest_Translate (mo_wordULt dflags)--  WordMulOp      -> \_ -> OpDest_Translate (mo_wordMul dflags)-  WordQuotOp     -> \_ -> OpDest_Translate (mo_wordUQuot dflags)-  WordRemOp      -> \_ -> OpDest_Translate (mo_wordURem dflags)--  AddrGeOp       -> \_ -> OpDest_Translate (mo_wordUGe dflags)-  AddrLeOp       -> \_ -> OpDest_Translate (mo_wordULe dflags)-  AddrGtOp       -> \_ -> OpDest_Translate (mo_wordUGt dflags)-  AddrLtOp       -> \_ -> OpDest_Translate (mo_wordULt dflags)---- Int8# signed ops--  Int8Extend     -> \_ -> OpDest_Translate (MO_SS_Conv W8 (wordWidth dflags))-  Int8Narrow     -> \_ -> OpDest_Translate (MO_SS_Conv (wordWidth dflags) W8)-  Int8NegOp      -> \_ -> OpDest_Translate (MO_S_Neg W8)-  Int8AddOp      -> \_ -> OpDest_Translate (MO_Add W8)-  Int8SubOp      -> \_ -> OpDest_Translate (MO_Sub W8)-  Int8MulOp      -> \_ -> OpDest_Translate (MO_Mul W8)-  Int8QuotOp     -> \_ -> OpDest_Translate (MO_S_Quot W8)-  Int8RemOp      -> \_ -> OpDest_Translate (MO_S_Rem W8)--  Int8EqOp       -> \_ -> OpDest_Translate (MO_Eq W8)-  Int8GeOp       -> \_ -> OpDest_Translate (MO_S_Ge W8)-  Int8GtOp       -> \_ -> OpDest_Translate (MO_S_Gt W8)-  Int8LeOp       -> \_ -> OpDest_Translate (MO_S_Le W8)-  Int8LtOp       -> \_ -> OpDest_Translate (MO_S_Lt W8)-  Int8NeOp       -> \_ -> OpDest_Translate (MO_Ne W8)---- Word8# unsigned ops--  Word8Extend     -> \_ -> OpDest_Translate (MO_UU_Conv W8 (wordWidth dflags))-  Word8Narrow     -> \_ -> OpDest_Translate (MO_UU_Conv (wordWidth dflags) W8)-  Word8NotOp      -> \_ -> OpDest_Translate (MO_Not W8)-  Word8AddOp      -> \_ -> OpDest_Translate (MO_Add W8)-  Word8SubOp      -> \_ -> OpDest_Translate (MO_Sub W8)-  Word8MulOp      -> \_ -> OpDest_Translate (MO_Mul W8)-  Word8QuotOp     -> \_ -> OpDest_Translate (MO_U_Quot W8)-  Word8RemOp      -> \_ -> OpDest_Translate (MO_U_Rem W8)--  Word8EqOp       -> \_ -> OpDest_Translate (MO_Eq W8)-  Word8GeOp       -> \_ -> OpDest_Translate (MO_U_Ge W8)-  Word8GtOp       -> \_ -> OpDest_Translate (MO_U_Gt W8)-  Word8LeOp       -> \_ -> OpDest_Translate (MO_U_Le W8)-  Word8LtOp       -> \_ -> OpDest_Translate (MO_U_Lt W8)-  Word8NeOp       -> \_ -> OpDest_Translate (MO_Ne W8)---- Int16# signed ops--  Int16Extend     -> \_ -> OpDest_Translate (MO_SS_Conv W16 (wordWidth dflags))-  Int16Narrow     -> \_ -> OpDest_Translate (MO_SS_Conv (wordWidth dflags) W16)-  Int16NegOp      -> \_ -> OpDest_Translate (MO_S_Neg W16)-  Int16AddOp      -> \_ -> OpDest_Translate (MO_Add W16)-  Int16SubOp      -> \_ -> OpDest_Translate (MO_Sub W16)-  Int16MulOp      -> \_ -> OpDest_Translate (MO_Mul W16)-  Int16QuotOp     -> \_ -> OpDest_Translate (MO_S_Quot W16)-  Int16RemOp      -> \_ -> OpDest_Translate (MO_S_Rem W16)--  Int16EqOp       -> \_ -> OpDest_Translate (MO_Eq W16)-  Int16GeOp       -> \_ -> OpDest_Translate (MO_S_Ge W16)-  Int16GtOp       -> \_ -> OpDest_Translate (MO_S_Gt W16)-  Int16LeOp       -> \_ -> OpDest_Translate (MO_S_Le W16)-  Int16LtOp       -> \_ -> OpDest_Translate (MO_S_Lt W16)-  Int16NeOp       -> \_ -> OpDest_Translate (MO_Ne W16)---- Word16# unsigned ops--  Word16Extend     -> \_ -> OpDest_Translate (MO_UU_Conv W16 (wordWidth dflags))-  Word16Narrow     -> \_ -> OpDest_Translate (MO_UU_Conv (wordWidth dflags) W16)-  Word16NotOp      -> \_ -> OpDest_Translate (MO_Not W16)-  Word16AddOp      -> \_ -> OpDest_Translate (MO_Add W16)-  Word16SubOp      -> \_ -> OpDest_Translate (MO_Sub W16)-  Word16MulOp      -> \_ -> OpDest_Translate (MO_Mul W16)-  Word16QuotOp     -> \_ -> OpDest_Translate (MO_U_Quot W16)-  Word16RemOp      -> \_ -> OpDest_Translate (MO_U_Rem W16)--  Word16EqOp       -> \_ -> OpDest_Translate (MO_Eq W16)-  Word16GeOp       -> \_ -> OpDest_Translate (MO_U_Ge W16)-  Word16GtOp       -> \_ -> OpDest_Translate (MO_U_Gt W16)-  Word16LeOp       -> \_ -> OpDest_Translate (MO_U_Le W16)-  Word16LtOp       -> \_ -> OpDest_Translate (MO_U_Lt W16)-  Word16NeOp       -> \_ -> OpDest_Translate (MO_Ne W16)---- Char# ops--  CharEqOp       -> \_ -> OpDest_Translate (MO_Eq (wordWidth dflags))-  CharNeOp       -> \_ -> OpDest_Translate (MO_Ne (wordWidth dflags))-  CharGeOp       -> \_ -> OpDest_Translate (MO_U_Ge (wordWidth dflags))-  CharLeOp       -> \_ -> OpDest_Translate (MO_U_Le (wordWidth dflags))-  CharGtOp       -> \_ -> OpDest_Translate (MO_U_Gt (wordWidth dflags))-  CharLtOp       -> \_ -> OpDest_Translate (MO_U_Lt (wordWidth dflags))---- Double ops--  DoubleEqOp     -> \_ -> OpDest_Translate (MO_F_Eq W64)-  DoubleNeOp     -> \_ -> OpDest_Translate (MO_F_Ne W64)-  DoubleGeOp     -> \_ -> OpDest_Translate (MO_F_Ge W64)-  DoubleLeOp     -> \_ -> OpDest_Translate (MO_F_Le W64)-  DoubleGtOp     -> \_ -> OpDest_Translate (MO_F_Gt W64)-  DoubleLtOp     -> \_ -> OpDest_Translate (MO_F_Lt W64)--  DoubleAddOp    -> \_ -> OpDest_Translate (MO_F_Add W64)-  DoubleSubOp    -> \_ -> OpDest_Translate (MO_F_Sub W64)-  DoubleMulOp    -> \_ -> OpDest_Translate (MO_F_Mul W64)-  DoubleDivOp    -> \_ -> OpDest_Translate (MO_F_Quot W64)-  DoubleNegOp    -> \_ -> OpDest_Translate (MO_F_Neg W64)---- Float ops--  FloatEqOp     -> \_ -> OpDest_Translate (MO_F_Eq W32)-  FloatNeOp     -> \_ -> OpDest_Translate (MO_F_Ne W32)-  FloatGeOp     -> \_ -> OpDest_Translate (MO_F_Ge W32)-  FloatLeOp     -> \_ -> OpDest_Translate (MO_F_Le W32)-  FloatGtOp     -> \_ -> OpDest_Translate (MO_F_Gt W32)-  FloatLtOp     -> \_ -> OpDest_Translate (MO_F_Lt W32)--  FloatAddOp    -> \_ -> OpDest_Translate (MO_F_Add  W32)-  FloatSubOp    -> \_ -> OpDest_Translate (MO_F_Sub  W32)-  FloatMulOp    -> \_ -> OpDest_Translate (MO_F_Mul  W32)-  FloatDivOp    -> \_ -> OpDest_Translate (MO_F_Quot W32)-  FloatNegOp    -> \_ -> OpDest_Translate (MO_F_Neg  W32)---- Vector ops--  (VecAddOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Add  n w)-  (VecSubOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Sub  n w)-  (VecMulOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Mul  n w)-  (VecDivOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Quot n w)-  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"-  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"-  (VecNegOp  FloatVec n w) -> \_ -> OpDest_Translate (MO_VF_Neg  n w)--  (VecAddOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Add   n w)-  (VecSubOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Sub   n w)-  (VecMulOp  IntVec n w) -> \_ -> OpDest_Translate (MO_V_Mul   n w)-  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Quot n w)-  (VecRemOp  IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Rem  n w)-  (VecNegOp  IntVec n w) -> \_ -> OpDest_Translate (MO_VS_Neg  n w)--  (VecAddOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Add   n w)-  (VecSubOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Sub   n w)-  (VecMulOp  WordVec n w) -> \_ -> OpDest_Translate (MO_V_Mul   n w)-  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp WordVec n w) -> \_ -> OpDest_Translate (MO_VU_Quot n w)-  (VecRemOp  WordVec n w) -> \_ -> OpDest_Translate (MO_VU_Rem  n w)-  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"---- Conversions--  Int2DoubleOp   -> \_ -> OpDest_Translate (MO_SF_Conv (wordWidth dflags) W64)-  Double2IntOp   -> \_ -> OpDest_Translate (MO_FS_Conv W64 (wordWidth dflags))--  Int2FloatOp    -> \_ -> OpDest_Translate (MO_SF_Conv (wordWidth dflags) W32)-  Float2IntOp    -> \_ -> OpDest_Translate (MO_FS_Conv W32 (wordWidth dflags))--  Float2DoubleOp -> \_ -> OpDest_Translate (MO_FF_Conv W32 W64)-  Double2FloatOp -> \_ -> OpDest_Translate (MO_FF_Conv W64 W32)---- Word comparisons masquerading as more exotic things.--  SameMutVarOp            -> \_ -> OpDest_Translate (mo_wordEq dflags)-  SameMVarOp              -> \_ -> OpDest_Translate (mo_wordEq dflags)-  SameMutableArrayOp      -> \_ -> OpDest_Translate (mo_wordEq dflags)-  SameMutableByteArrayOp  -> \_ -> OpDest_Translate (mo_wordEq dflags)-  SameMutableArrayArrayOp -> \_ -> OpDest_Translate (mo_wordEq dflags)-  SameSmallMutableArrayOp -> \_ -> OpDest_Translate (mo_wordEq dflags)-  SameTVarOp              -> \_ -> OpDest_Translate (mo_wordEq dflags)-  EqStablePtrOp           -> \_ -> OpDest_Translate (mo_wordEq dflags)--- See Note [Comparing stable names]-  EqStableNameOp          -> \_ -> OpDest_Translate (mo_wordEq dflags)--  IntQuotRemOp -> \args -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem  (wordWidth dflags))-    else Right (genericIntQuotRemOp (wordWidth dflags))--  Int8QuotRemOp -> \args -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W8)-    else Right (genericIntQuotRemOp W8)--  Int16QuotRemOp -> \args -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W16)-    else Right (genericIntQuotRemOp W16)--  WordQuotRemOp -> \args -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem  (wordWidth dflags))-    else Right (genericWordQuotRemOp (wordWidth dflags))--  WordQuotRem2Op -> \_ -> OpDest_CallishHandledLater $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_U_QuotRem2 (wordWidth dflags))-    else Right (genericWordQuotRem2Op dflags)--  Word8QuotRemOp -> \args -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W8)-    else Right (genericWordQuotRemOp W8)--  Word16QuotRemOp -> \args -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W16)-    else Right (genericWordQuotRemOp W16)--  WordAdd2Op -> \_ -> OpDest_CallishHandledLater $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_Add2       (wordWidth dflags))-    else Right genericWordAdd2Op--  WordAddCOp -> \_ -> OpDest_CallishHandledLater $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_AddWordC   (wordWidth dflags))-    else Right genericWordAddCOp--  WordSubCOp -> \_ -> OpDest_CallishHandledLater $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_SubWordC   (wordWidth dflags))-    else Right genericWordSubCOp--  IntAddCOp -> \_ -> OpDest_CallishHandledLater $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_AddIntC    (wordWidth dflags))-    else Right genericIntAddCOp--  IntSubCOp -> \_ -> OpDest_CallishHandledLater $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_SubIntC    (wordWidth dflags))-    else Right genericIntSubCOp--  WordMul2Op -> \_ -> OpDest_CallishHandledLater $-    if ncg && (x86ish || ppc) || llvm-    then Left (MO_U_Mul2     (wordWidth dflags))-    else Right genericWordMul2Op--  IntMul2Op  -> \_ -> OpDest_CallishHandledLater $-    if ncg && x86ish-    then Left (MO_S_Mul2     (wordWidth dflags))-    else Right genericIntMul2Op--  FloatFabsOp -> \_ -> OpDest_CallishHandledLater $-    if (ncg && x86ish || ppc) || llvm-    then Left MO_F32_Fabs-    else Right $ genericFabsOp W32--  DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $-    if (ncg && x86ish || ppc) || llvm-    then Left MO_F64_Fabs-    else Right $ genericFabsOp W64--  TagToEnumOp -> panic "emitPrimOp: handled above in cgOpApp"---- Out of line primops.--- TODO compiler need not know about these--  UnsafeThawArrayOp -> alwaysExternal-  CasArrayOp -> alwaysExternal-  UnsafeThawSmallArrayOp -> alwaysExternal-  CasSmallArrayOp -> alwaysExternal-  NewPinnedByteArrayOp_Char -> alwaysExternal-  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal-  MutableByteArrayIsPinnedOp -> alwaysExternal-  DoubleDecode_2IntOp -> alwaysExternal-  DoubleDecode_Int64Op -> alwaysExternal-  FloatDecode_IntOp -> alwaysExternal-  ByteArrayIsPinnedOp -> alwaysExternal-  ShrinkMutableByteArrayOp_Char -> alwaysExternal-  ResizeMutableByteArrayOp_Char -> alwaysExternal-  ShrinkSmallMutableArrayOp_Char -> alwaysExternal-  NewArrayArrayOp -> alwaysExternal-  NewMutVarOp -> alwaysExternal-  AtomicModifyMutVar2Op -> alwaysExternal-  AtomicModifyMutVar_Op -> alwaysExternal-  CasMutVarOp -> alwaysExternal-  CatchOp -> alwaysExternal-  RaiseOp -> alwaysExternal-  RaiseIOOp -> alwaysExternal-  MaskAsyncExceptionsOp -> alwaysExternal-  MaskUninterruptibleOp -> alwaysExternal-  UnmaskAsyncExceptionsOp -> alwaysExternal-  MaskStatus -> alwaysExternal-  AtomicallyOp -> alwaysExternal-  RetryOp -> alwaysExternal-  CatchRetryOp -> alwaysExternal-  CatchSTMOp -> alwaysExternal-  NewTVarOp -> alwaysExternal-  ReadTVarOp -> alwaysExternal-  ReadTVarIOOp -> alwaysExternal-  WriteTVarOp -> alwaysExternal-  NewMVarOp -> alwaysExternal-  TakeMVarOp -> alwaysExternal-  TryTakeMVarOp -> alwaysExternal-  PutMVarOp -> alwaysExternal-  TryPutMVarOp -> alwaysExternal-  ReadMVarOp -> alwaysExternal-  TryReadMVarOp -> alwaysExternal-  IsEmptyMVarOp -> alwaysExternal-  DelayOp -> alwaysExternal-  WaitReadOp -> alwaysExternal-  WaitWriteOp -> alwaysExternal-  ForkOp -> alwaysExternal-  ForkOnOp -> alwaysExternal-  KillThreadOp -> alwaysExternal-  YieldOp -> alwaysExternal-  LabelThreadOp -> alwaysExternal-  IsCurrentThreadBoundOp -> alwaysExternal-  NoDuplicateOp -> alwaysExternal-  ThreadStatusOp -> alwaysExternal-  MkWeakOp -> alwaysExternal-  MkWeakNoFinalizerOp -> alwaysExternal-  AddCFinalizerToWeakOp -> alwaysExternal-  DeRefWeakOp -> alwaysExternal-  FinalizeWeakOp -> alwaysExternal-  MakeStablePtrOp -> alwaysExternal-  DeRefStablePtrOp -> alwaysExternal-  MakeStableNameOp -> alwaysExternal-  CompactNewOp -> alwaysExternal-  CompactResizeOp -> alwaysExternal-  CompactContainsOp -> alwaysExternal-  CompactContainsAnyOp -> alwaysExternal-  CompactGetFirstBlockOp -> alwaysExternal-  CompactGetNextBlockOp -> alwaysExternal-  CompactAllocateBlockOp -> alwaysExternal-  CompactFixupPointersOp -> alwaysExternal-  CompactAdd -> alwaysExternal-  CompactAddWithSharing -> alwaysExternal-  CompactSize -> alwaysExternal-  SeqOp -> alwaysExternal-  GetSparkOp -> alwaysExternal-  NumSparks -> alwaysExternal-  DataToTagOp -> alwaysExternal-  MkApUpd0_Op -> alwaysExternal-  NewBCOOp -> alwaysExternal-  UnpackClosureOp -> alwaysExternal-  ClosureSizeOp -> alwaysExternal-  GetApStackValOp -> alwaysExternal-  ClearCCSOp -> alwaysExternal-  TraceEventOp -> alwaysExternal-  TraceEventBinaryOp -> alwaysExternal-  TraceMarkerOp -> alwaysExternal-  SetThreadAllocationCounter -> alwaysExternal-- where-  alwaysExternal = \_ -> OpDest_External-  -- Note [QuotRem optimization]-  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~-  ---  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops-  -- (shift, .&.).-  ---  -- Currently we only support optimization (performed in CmmOpt) when the-  -- constant is a power of 2. #9041 tracks the implementation of the general-  -- optimization.-  ---  -- `quotRem` can be optimized in the same way. However as it returns two values,-  -- it is implemented as a "callish" primop which is harder to match and-  -- to transform later on. For simplicity, the current implementation detects cases-  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem-  -- primop into two CMM quot and rem primops.-  quotRemCanBeOptimized = \case-    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)-    _                         -> False--  ncg = case hscTarget dflags of-           HscAsm -> True-           _      -> False-  llvm = case hscTarget dflags of-           HscLlvm -> True-           _       -> False-  x86ish = case platformArch (targetPlatform dflags) of-             ArchX86    -> True-             ArchX86_64 -> True-             _          -> False-  ppc = case platformArch (targetPlatform dflags) of-          ArchPPC      -> True-          ArchPPC_64 _ -> True-          _            -> False---- | Helper datatype used to ensure completion while keeping code smaller. Could--- be totally eliminated in optimized builds.-data OpDest-  = OpDest_Nop-  | OpDest_Narrow !(Width -> Width -> MachOp, Width)-  -- | These primops are implemented by CallishMachOps, because they sometimes-  -- turn into foreign calls depending on the backend.-  | OpDest_Callish !CallishMachOp-  | OpDest_Translate !MachOp-  | OpDest_CallishHandledLater (Either CallishMachOp GenericOp)-  | OpDest_External-  -- | Basically a "manual" case, rather than one of the common repetitive forms-  -- above. The results are a parameter to the returned function so we know the-  -- choice of variant never depends on them.-  | OpDest_AllDone ([LocalReg] -- where to put the results-                    -> FCode ())---- | Wrapper around '@dispatchPrimop@' which implements the cases represented--- with '@OpDest@'.------ Returns 'Nothing' if this primop should use its out-of-line implementation--- (defined elsewhere) and 'Just' together with a code generating function that--- takes the output regs as arguments otherwise.-emitPrimOp :: DynFlags-           -> PrimOp            -- the op-           -> [CmmExpr]         -- arguments-           -> Maybe ([LocalReg]        -- where to put the results-                      -> FCode ())---- The rest just translate straightforwardly-emitPrimOp dflags op args = case dispatchPrimop dflags op args of-  OpDest_Nop -> Just $ \[res] -> emitAssign (CmmLocal res) arg-    where [arg] = args--  OpDest_Narrow (mop, rep) -> Just $ \[res] -> emitAssign (CmmLocal res) $-    CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]-    where [arg] = args--  OpDest_Callish prim -> Just $ \[res] -> emitPrimCall [res] prim args--  OpDest_Translate mop -> Just $ \[res] -> do-    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)-    emit stmt--  OpDest_CallishHandledLater callOrNot -> Just $ \res0 -> case callOrNot of-          Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args-          Right gen -> gen res0 args--  OpDest_AllDone f -> Just $ f--  OpDest_External -> Nothing--type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()--genericIntQuotRemOp :: Width -> GenericOp-genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]-   = emit $ mkAssign (CmmLocal res_q)-              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>-            mkAssign (CmmLocal res_r)-              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])-genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"--genericWordQuotRemOp :: Width -> GenericOp-genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]-    = emit $ mkAssign (CmmLocal res_q)-               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>-             mkAssign (CmmLocal res_r)-               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])-genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"--genericWordQuotRem2Op :: DynFlags -> GenericOp-genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]-    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low-    where    ty = cmmExprType dflags arg_x_high-             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]-             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]-             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]-             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]-             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]-             zero   = lit 0-             one    = lit 1-             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)-             lit i = CmmLit (CmmInt i (wordWidth dflags))--             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph-             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>-                                      mkAssign (CmmLocal res_r) high)-             f i acc high low =-                 do roverflowedBit <- newTemp ty-                    rhigh'         <- newTemp ty-                    rhigh''        <- newTemp ty-                    rlow'          <- newTemp ty-                    risge          <- newTemp ty-                    racc'          <- newTemp ty-                    let high'         = CmmReg (CmmLocal rhigh')-                        isge          = CmmReg (CmmLocal risge)-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)-                    let this = catAGraphs-                               [mkAssign (CmmLocal roverflowedBit)-                                          (shr high negone),-                                mkAssign (CmmLocal rhigh')-                                          (or (shl high one) (shr low negone)),-                                mkAssign (CmmLocal rlow')-                                          (shl low one),-                                mkAssign (CmmLocal risge)-                                          (or (overflowedBit `ne` zero)-                                              (high' `ge` arg_y)),-                                mkAssign (CmmLocal rhigh'')-                                          (high' `minus` (arg_y `times` isge)),-                                mkAssign (CmmLocal racc')-                                          (or (shl acc one) isge)]-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))-                                      (CmmReg (CmmLocal rhigh''))-                                      (CmmReg (CmmLocal rlow'))-                    return (this <*> rest)-genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"--genericWordAdd2Op :: GenericOp-genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]-  = do dflags <- getDynFlags-       r1 <- newTemp (cmmExprType dflags arg_x)-       r2 <- newTemp (cmmExprType dflags arg_x)-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                                (wordWidth dflags))-           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))-       emit $ catAGraphs-          [mkAssign (CmmLocal r1)-               (add (bottomHalf arg_x) (bottomHalf arg_y)),-           mkAssign (CmmLocal r2)-               (add (topHalf (CmmReg (CmmLocal r1)))-                    (add (topHalf arg_x) (topHalf arg_y))),-           mkAssign (CmmLocal res_h)-               (topHalf (CmmReg (CmmLocal r2))),-           mkAssign (CmmLocal res_l)-               (or (toTopHalf (CmmReg (CmmLocal r2)))-                   (bottomHalf (CmmReg (CmmLocal r1))))]-genericWordAdd2Op _ _ = panic "genericWordAdd2Op"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:------ @---    c = a&b | (a|b)&~r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordAddCOp :: GenericOp-genericWordAddCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [aa,bb],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [aa,bb],-                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]-              ]-            ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericWordAddCOp _ _ = panic "genericWordAddCOp"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:------ @---    c = ~a&b | (~a|b)&r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordSubCOp :: GenericOp-genericWordSubCOp [res_r, res_c] [aa, bb]- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-            CmmMachOp (mo_wordOr dflags) [-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordNot dflags) [aa],-                bb-              ],-              CmmMachOp (mo_wordAnd dflags) [-                CmmMachOp (mo_wordOr dflags) [-                  CmmMachOp (mo_wordNot dflags) [aa],-                  bb-                ],-                CmmReg (CmmLocal res_r)-              ]-            ],-            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericWordSubCOp _ _ = panic "genericWordSubCOp"--genericIntAddCOp :: GenericOp-genericIntAddCOp [res_r, res_c] [aa, bb]-{--   With some bit-twiddling, we can define int{Add,Sub}Czh portably in-   C, and without needing any comparisons.  This may not be the-   fastest way to do it - if you have better code, please send it! --SDM--   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.--   We currently don't make use of the r value if c is != 0 (i.e.-   overflow), we just convert to big integers and try again.  This-   could be improved by making r and c the correct values for-   plugging into a new J#.--   { r = ((I_)(a)) + ((I_)(b));                                 \-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \-         >> (BITS_IN (I_) - 1);                                 \-   }-   Wading through the mass of bracketry, it seems to reduce to:-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)---}- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericIntAddCOp _ _ = panic "genericIntAddCOp"--genericIntSubCOp :: GenericOp-genericIntSubCOp [res_r, res_c] [aa, bb]-{- Similarly:-   #define subIntCzh(r,c,a,b)                                   \-   { r = ((I_)(a)) - ((I_)(b));                                 \-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \-         >> (BITS_IN (I_) - 1);                                 \-   }--   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)--}- = do dflags <- getDynFlags-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr dflags) [-                CmmMachOp (mo_wordAnd dflags) [-                    CmmMachOp (mo_wordXor dflags) [aa,bb],-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)-          ]-        ]-genericIntSubCOp _ _ = panic "genericIntSubCOp"--genericWordMul2Op :: GenericOp-genericWordMul2Op [res_h, res_l] [arg_x, arg_y]- = do dflags <- getDynFlags-      let t = cmmExprType dflags arg_x-      xlyl <- liftM CmmLocal $ newTemp t-      xlyh <- liftM CmmLocal $ newTemp t-      xhyl <- liftM CmmLocal $ newTemp t-      r    <- liftM CmmLocal $ newTemp t-      -- This generic implementation is very simple and slow. We might-      -- well be able to do better, but for now this at least works.-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]-          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]-          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]-          sum = foldl1 add-          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]-          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))-                               (wordWidth dflags))-          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))-      emit $ catAGraphs-             [mkAssign xlyl-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),-              mkAssign xlyh-                  (mul (bottomHalf arg_x) (topHalf arg_y)),-              mkAssign xhyl-                  (mul (topHalf arg_x) (bottomHalf arg_y)),-              mkAssign r-                  (sum [topHalf    (CmmReg xlyl),-                        bottomHalf (CmmReg xhyl),-                        bottomHalf (CmmReg xlyh)]),-              mkAssign (CmmLocal res_l)-                  (or (bottomHalf (CmmReg xlyl))-                      (toTopHalf (CmmReg r))),-              mkAssign (CmmLocal res_h)-                  (sum [mul (topHalf arg_x) (topHalf arg_y),-                        topHalf (CmmReg xhyl),-                        topHalf (CmmReg xlyh),-                        topHalf (CmmReg r)])]-genericWordMul2Op _ _ = panic "genericWordMul2Op"--genericIntMul2Op :: GenericOp-genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]- = do dflags <- getDynFlags-      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174-      let t = cmmExprType dflags arg_x-      p   <- newTemp t-      -- 1) compute the multiplication as if numbers were unsigned-      let wordMul2 = fromMaybe (panic "Unsupported out-of-line WordMul2Op")-                               (emitPrimOp dflags WordMul2Op [arg_x,arg_y])-      wordMul2 [p,res_l]-      -- 2) correct the high bits of the unsigned result-      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]-          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]-          and x y     = CmmMachOp (MO_And   ww) [x, y]-          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]-          f   x y     = (carryFill x) `and` y-          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)-          rl x        = CmmReg (CmmLocal x)-          ww          = wordWidth dflags-      emit $ catAGraphs-             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)-             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))-             ]-genericIntMul2Op _ _ = panic "genericIntMul2Op"---- This replicates what we had in libraries/base/GHC/Float.hs:------    abs x    | x == 0    = 0 -- handles (-0.0)---             | x >  0    = x---             | otherwise = negateFloat x-genericFabsOp :: Width -> GenericOp-genericFabsOp w [res_r] [aa]- = do dflags <- getDynFlags-      let zero   = CmmLit (CmmFloat 0 w)--          eq x y = CmmMachOp (MO_F_Eq w) [x, y]-          gt x y = CmmMachOp (MO_F_Gt w) [x, y]--          neg x  = CmmMachOp (MO_F_Neg w) [x]--          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]-          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]--      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)-      let g3 = catAGraphs [mkAssign res_t aa,-                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]--      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3--      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4--genericFabsOp _ _ _ = panic "genericFabsOp"---- Note [Comparing stable names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ A StableName# is actually a pointer to a stable name object (SNO)--- containing an index into the stable name table (SNT). We--- used to compare StableName#s by following the pointers to the--- SNOs and checking whether they held the same SNT indices. However,--- this is not necessary: there is a one-to-one correspondence--- between SNOs and entries in the SNT, so simple pointer equality--- does the trick.----------------------------------------------------------------------------------- Helpers for translating various minor variants of array indexing.--doIndexOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx-doIndexOffAddrOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"--doIndexOffAddrOpAs :: Maybe MachOp-                   -> CmmType-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx-doIndexOffAddrOpAs _ _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"--doIndexByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx-doIndexByteArrayOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"--doIndexByteArrayOpAs :: Maybe MachOp-                    -> CmmType-                    -> CmmType-                    -> [LocalReg]-                    -> [CmmExpr]-                    -> FCode ()-doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx-doIndexByteArrayOpAs _ _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"--doReadPtrArrayOp :: LocalReg-                 -> CmmExpr-                 -> CmmExpr-                 -> FCode ()-doReadPtrArrayOp res addr idx-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx--doWriteOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val-doWriteOffAddrOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"--doWriteByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = do dflags <- getDynFlags-        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val-doWriteByteArrayOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"--doWritePtrArrayOp :: CmmExpr-                  -> CmmExpr-                  -> CmmExpr-                  -> FCode ()-doWritePtrArrayOp addr idx val-  = do dflags <- getDynFlags-       let ty = cmmExprType dflags val-           hdr_size = arrPtrsHdrSize dflags-       -- Update remembered set for non-moving collector-       whenUpdRemSetEnabled dflags-           $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)-       -- This write barrier is to ensure that the heap writes to the object-       -- referred to by val have happened before we write val into the array.-       -- See #12469 for details.-       emitPrimCall [] MO_WriteBarrier []-       mkBasicIndexedWrite hdr_size Nothing addr ty idx val-       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))-       -- the write barrier.  We must write a byte into the mark table:-       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]-       emit $ mkStore (-         cmmOffsetExpr dflags-          (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)-                         (loadArrPtrsSize dflags addr))-          (CmmMachOp (mo_wordUShr dflags) [idx,-                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])-         ) (CmmLit (CmmInt 1 W8))--loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)- where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags--mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes-                   -> Maybe MachOp -- Optional result cast-                   -> CmmType      -- Type of element we are accessing-                   -> LocalReg     -- Destination-                   -> CmmExpr      -- Base address-                   -> CmmType      -- Type of element by which we are indexing-                   -> CmmExpr      -- Index-                   -> FCode ()-mkBasicIndexedRead off Nothing ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx-   = do dflags <- getDynFlags-        emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])--mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes-                    -> Maybe MachOp -- Optional value cast-                    -> CmmExpr      -- Base address-                    -> CmmType      -- Type of element by which we are indexing-                    -> CmmExpr      -- Index-                    -> CmmExpr      -- Value to write-                    -> FCode ()-mkBasicIndexedWrite off Nothing base idx_ty idx val-   = do dflags <- getDynFlags-        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val-mkBasicIndexedWrite off (Just cast) base idx_ty idx val-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])---- ------------------------------------------------------------------------------- Misc utils--cmmIndexOffExpr :: DynFlags-                -> ByteOff  -- Initial offset in bytes-                -> Width    -- Width of element by which we are indexing-                -> CmmExpr  -- Base address-                -> CmmExpr  -- Index-                -> CmmExpr-cmmIndexOffExpr dflags off width base idx-   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx--cmmLoadIndexOffExpr :: DynFlags-                    -> ByteOff  -- Initial offset in bytes-                    -> CmmType  -- Type of element we are accessing-                    -> CmmExpr  -- Base address-                    -> CmmType  -- Type of element by which we are indexing-                    -> CmmExpr  -- Index-                    -> CmmExpr-cmmLoadIndexOffExpr dflags off ty base idx_ty idx-   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty--setInfo :: CmmExpr -> CmmExpr -> CmmAGraph-setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr----------------------------------------------------------------------------------- Helpers for translating vector primops.--vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType-vecVmmType pocat n w = vec n (vecCmmCat pocat w)--vecCmmCat :: PrimOpVecCat -> Width -> CmmType-vecCmmCat IntVec   = cmmBits-vecCmmCat WordVec  = cmmBits-vecCmmCat FloatVec = cmmFloat--vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemInjectCast _      FloatVec _   =  Nothing-vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      IntVec   W64 =  Nothing-vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)-vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)-vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)-vecElemInjectCast _      WordVec  W64 =  Nothing-vecElemInjectCast _      _        _   =  Nothing--vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemProjectCast _      FloatVec _   =  Nothing-vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)-vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)-vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)-vecElemProjectCast _      IntVec   W64 =  Nothing-vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)-vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)-vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)-vecElemProjectCast _      WordVec  W64 =  Nothing-vecElemProjectCast _      _        _   =  Nothing----- NOTE [SIMD Design for the future]--- Check to make sure that we can generate code for the specified vector type--- given the current set of dynamic flags.--- Currently these checks are specific to x86 and x86_64 architecture.--- This should be fixed!--- In particular,--- 1) Add better support for other architectures! (this may require a redesign)--- 2) Decouple design choices from LLVM's pseudo SIMD model!---   The high level LLVM naive rep makes per CPU family SIMD generation is own---   optimization problem, and hides important differences in eg ARM vs x86_64 simd--- 3) Depending on the architecture, the SIMD registers may also support general---    computations on Float/Double/Word/Int scalars, but currently on---    for example x86_64, we always put Word/Int (or sized) in GPR---    (general purpose) registers. Would relaxing that allow for---    useful optimization opportunities?---      Phrased differently, it is worth experimenting with supporting---    different register mapping strategies than we currently have, especially if---    someday we want SIMD to be a first class denizen in GHC along with scalar---    values!---      The current design with respect to register mapping of scalars could---    very well be the best,but exploring the  design space and doing careful---    measurments is the only only way to validate that.+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prim (+   cgOpApp,+   shouldInlinePrimOp+ ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import GHC.StgToCmm.Layout+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof ( costCentreFrom )++import DynFlags+import GHC.Platform+import BasicTypes+import GHC.Cmm.BlockId+import GHC.Cmm.Graph+import GHC.Stg.Syntax+import GHC.Cmm+import Module   ( rtsUnitId )+import Type     ( Type, tyConAppTyCon )+import TyCon+import GHC.Cmm.CLabel+import GHC.Cmm.Utils+import PrimOp+import GHC.Runtime.Layout+import FastString+import Outputable+import Util+import Data.Maybe++import Data.Bits ((.&.), bit)+import Control.Monad (liftM, when, unless)++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall ty) stg_args res_ty+  = cgForeignCall fcall ty stg_args res_ty+      -- Note [Foreign call results]++cgOpApp (StgPrimOp primop) args res_ty = do+    dflags <- getDynFlags+    cmm_args <- getNonVoidArgAmodes args+    case emitPrimOp dflags primop cmm_args of+        PrimopCmmEmit_External -> do  -- out-of-line+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args++        PrimopCmmEmit_Raw f -> do+          exprs <- f res_ty+          emitReturn exprs++        PrimopCmmEmit_IntoRegs f  -- inline+          | ReturnsPrim VoidRep <- result_info+          -> do f []+                emitReturn []++          | ReturnsPrim rep <- result_info+          -> do dflags <- getDynFlags+                res <- newTemp (primRepCmmType dflags rep)+                f [res]+                emitReturn [CmmReg (CmmLocal res)]++          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+                f regs+                emitReturn (map (CmmReg . CmmLocal) regs)++          | otherwise -> panic "cgOpApp"+          where+             result_info = getPrimOpResultInfo primop++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of+  PrimopCmmEmit_External -> False+  PrimopCmmEmit_IntoRegs _ -> True+  PrimopCmmEmit_Raw _ -> True++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+-- ByteOff (or some other fixed width signed type) to represent+-- array sizes or indices. This means that these will overflow for+-- large enough sizes.++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++-- | The big function handling all the primops.+--+-- In the simple case, there is just one implementation, and we emit that.+--+-- In more complex cases, there is a foreign call (out of line) fallback. This+-- might happen e.g. if there's enough static information, such as statically+-- know arguments.+emitPrimOp+  :: DynFlags+  -> PrimOp            -- ^ The primop+  -> [CmmExpr]         -- ^ The primop arguments+  -> PrimopCmmEmit+emitPrimOp dflags = \case+  NewByteArrayOp_Char -> \case+    [(CmmLit (CmmInt n w))]+      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone  $ \ [res] -> doNewByteArrayOp res (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel+        [ (mkIntExpr dflags (fromInteger n),+           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)+        , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),+           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopyArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewSmallArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] ->+        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+        [ (mkIntExpr dflags (fromInteger n),+           fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopySmallArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopySmallMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opAllDone $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++-- First we handle various awkward cases specially.++  ParOp -> \[arg] -> opAllDone $ \[res] -> do+    -- for now, just implement this in a C function+    -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), (arg,AddrHint)]++  SparkOp -> \[arg] -> opAllDone $ \[res] -> do+    -- returns the value of arg in res.  We're going to therefore+    -- refer to arg twice (once to pass to newSpark(), and once to+    -- assign to res), so put it in a temporary.+    tmp <- assignTemp arg+    tmp2 <- newTemp (bWord dflags)+    emitCCall+        [(tmp2,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++  GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do+    let+      val+       | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)+       | otherwise                      = CmmLit (zeroCLit dflags)+    emitAssign (CmmLocal res) val++  GetCurrentCCSOp -> \[_] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) cccsExpr++  MyThreadIdOp -> \[] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) currentTSOExpr++  ReadMutVarOp -> \[mutv] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++  WriteMutVarOp -> \[mutv, var] -> opAllDone $ \res@[] -> do+    old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)+    emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++    -- Without this write barrier, other CPUs may see this pointer before+    -- the writes for the closure it points to have occurred.+    -- Note that this also must come after we read the old value to ensure+    -- that the read of old_val comes before another core's write to the+    -- MutVar's value.+    emitPrimCall res MO_WriteBarrier []+    emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var+    emitCCall+            [{-no results-}]+            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+  SizeofByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  GetSizeofMutableByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+++--  #define touchzh(o)                  /* nothing */+  TouchOp -> \args@[_] -> opAllDone $ \res@[] -> do+    emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  ByteArrayContents_Char -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+  StableNameToIntOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+  AddrToAnyOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+  AnyToAddrOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);+--        r = a;+--      }+  UnsafeFreezeArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeArrayArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+  UnsafeFreezeByteArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++  ReadArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  IndexArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  WriteArrayOp -> \[obj, ix, v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v++  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadPtrArrayOp res obj ix+  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWritePtrArrayOp obj ix v++  ReadSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadSmallPtrArrayOp res obj ix+  IndexSmallArrayOp -> \[obj, ix] -> opAllDone $ \[res] -> do+    doReadSmallPtrArrayOp res obj ix+  WriteSmallArrayOp -> \[obj,ix,v] -> opAllDone $ \[] -> do+    doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++  SizeofArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg+      (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord dflags))+  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofSmallArrayOp -> \[arg] -> opAllDone $ \[res] -> do+    emit $ mkAssign (CmmLocal res)+     (cmmLoadIndexW dflags arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord dflags))++  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp++-- IndexXXXoffAddr++  IndexOffAddrOp_Char -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+  IndexOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Int -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Word -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Float -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f32 res args+  IndexOffAddrOp_Double -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f64 res args+  IndexOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  IndexOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+  IndexOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+  IndexOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args+  IndexOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+  IndexOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+  IndexOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++  ReadOffAddrOp_Char -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+  ReadOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Int -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Word -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Float -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f32 res args+  ReadOffAddrOp_Double -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing f64 res args+  ReadOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing (bWord dflags) res args+  ReadOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+  ReadOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+  ReadOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args+  ReadOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+  ReadOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+  ReadOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++  IndexByteArrayOp_Char -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+  IndexByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+  IndexByteArrayOp_Int -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Word -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Float -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f32 res args+  IndexByteArrayOp_Double -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f64 res args+  IndexByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  IndexByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+  IndexByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+  IndexByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+  IndexByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args+  IndexByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+  IndexByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+  IndexByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+  IndexByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++  ReadByteArrayOp_Char -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+  ReadByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+  ReadByteArrayOp_Int -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Word -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Float -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f32 res args+  ReadByteArrayOp_Double -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing f64 res args+  ReadByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing (bWord dflags) res args+  ReadByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+  ReadByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+  ReadByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+  ReadByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args+  ReadByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+  ReadByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+  ReadByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+  ReadByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++  IndexByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+  IndexByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  IndexByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  IndexByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  IndexByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+  IndexByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  IndexByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+  IndexByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  IndexByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++  ReadByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+  ReadByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  ReadByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  ReadByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+  ReadByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+  ReadByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  ReadByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+  ReadByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+  ReadByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++  WriteOffAddrOp_Char -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_WideChar -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Int -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Word -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Addr -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Float -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing f32 res args+  WriteOffAddrOp_Double -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing f64 res args+  WriteOffAddrOp_StablePtr -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing (bWord dflags) res args+  WriteOffAddrOp_Int8 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_Int16 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteOffAddrOp_Int32 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Int64 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing b64 res args+  WriteOffAddrOp_Word8 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteOffAddrOp_Word16 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteOffAddrOp_Word32 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteOffAddrOp_Word64 -> \args -> opAllDone $ \res -> do+    doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++  WriteByteArrayOp_Char -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_WideChar -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Int -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Word -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Addr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Float -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing f32 res args+  WriteByteArrayOp_Double -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing f64 res args+  WriteByteArrayOp_StablePtr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing (bWord dflags) res args+  WriteByteArrayOp_Int8 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_Int16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteByteArrayOp_Int32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Int64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b64 res args+  WriteByteArrayOp_Word8 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+  WriteByteArrayOp_Word16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+  WriteByteArrayOp_Word32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+  WriteByteArrayOp_Word64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++  WriteByteArrayOp_Word8AsChar -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+  WriteByteArrayOp_Word8AsWideChar -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsAddr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsFloat -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsDouble -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsStablePtr -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsInt64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord16 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+  WriteByteArrayOp_Word8AsWord32 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+  WriteByteArrayOp_Word8AsWord64 -> \args -> opAllDone $ \res -> do+    doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do+    doCopyByteArrayOp src src_off dst dst_off n+  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opAllDone $ \[] -> do+    doCopyMutableByteArrayOp src src_off dst dst_off n+  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do+    doCopyByteArrayToAddrOp src src_off dst n+  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opAllDone $ \[] -> do+    doCopyMutableByteArrayToAddrOp src src_off dst n+  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opAllDone $ \[] -> do+    doCopyAddrToByteArrayOp src dst dst_off n+  SetByteArrayOp -> \[ba,off,len,c] -> opAllDone $ \[] -> do+    doSetByteArrayOp ba off len c++-- Comparing byte arrays+  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opAllDone $ \[res] -> do+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++  BSwap16Op -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w W16+  BSwap32Op -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w W32+  BSwap64Op -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w W64+  BSwapOp -> \[w] -> opAllDone $ \[res] -> do+    emitBSwapCall res w (wordWidth dflags)++  BRev8Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W8+  BRev16Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W16+  BRev32Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W32+  BRev64Op -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w W64+  BRevOp -> \[w] -> opAllDone $ \[res] -> do+    emitBRevCall res w (wordWidth dflags)++-- Population count+  PopCnt8Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W8+  PopCnt16Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W16+  PopCnt32Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W32+  PopCnt64Op -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w W64+  PopCntOp -> \[w] -> opAllDone $ \[res] -> do+    emitPopCntCall res w (wordWidth dflags)++-- Parallel bit deposit+  Pdep8Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W8+  Pdep16Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W16+  Pdep32Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W32+  Pdep64Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask W64+  PdepOp -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPdepCall res src mask (wordWidth dflags)++-- Parallel bit extract+  Pext8Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W8+  Pext16Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W16+  Pext32Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W32+  Pext64Op -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask W64+  PextOp -> \[src, mask] -> opAllDone $ \[res] -> do+    emitPextCall res src mask (wordWidth dflags)++-- count leading zeros+  Clz8Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W8+  Clz16Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W16+  Clz32Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W32+  Clz64Op -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w W64+  ClzOp -> \[w] -> opAllDone $ \[res] -> do+    emitClzCall res w (wordWidth dflags)++-- count trailing zeros+  Ctz8Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W8+  Ctz16Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W16+  Ctz32Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W32+  Ctz64Op -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w W64+  CtzOp -> \[w] -> opAllDone $ \[res] -> do+    emitCtzCall res w (wordWidth dflags)++-- Unsigned int to floating point conversions+  Word2FloatOp -> \[w] -> opAllDone $ \[res] -> do+    emitPrimCall [res] (MO_UF_Conv W32) [w]+  Word2DoubleOp -> \[w] -> opAllDone $ \[res] -> do+    emitPrimCall [res] (MO_UF_Conv W64) [w]++-- SIMD primops+  (VecBroadcastOp vcat n w) -> \[e] -> opAllDone $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res+   where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecPackOp vcat n w) -> \es -> opAllDone $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    when (es `lengthIsNot` n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res+   where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecUnpackOp vcat n w) -> \[arg] -> opAllDone $ \res -> do+    checkVecCompatibility dflags vcat n w+    when (res `lengthIsNot` n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecInsertOp vcat n w) -> \[v,e,i] -> opAllDone $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecReadByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecWriteByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecReadOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecWriteOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opAllDone $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+  PrefetchByteArrayOp3         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 3  args+  PrefetchMutableByteArrayOp3  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 3  args+  PrefetchAddrOp3              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp  3  args+  PrefetchValueOp3             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 3 args++  PrefetchByteArrayOp2         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 2  args+  PrefetchMutableByteArrayOp2  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 2  args+  PrefetchAddrOp2              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp 2  args+  PrefetchValueOp2             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 2 args+  PrefetchByteArrayOp1         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 1  args+  PrefetchMutableByteArrayOp1  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 1  args+  PrefetchAddrOp1              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp 1  args+  PrefetchValueOp1             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 1 args++  PrefetchByteArrayOp0         -> \args -> opAllDone $ \[] -> do+    doPrefetchByteArrayOp 0  args+  PrefetchMutableByteArrayOp0  -> \args -> opAllDone $ \[] -> do+    doPrefetchMutableByteArrayOp 0  args+  PrefetchAddrOp0              -> \args -> opAllDone $ \[] -> do+    doPrefetchAddrOp 0  args+  PrefetchValueOp0             -> \args -> opAllDone $ \[] -> do+    doPrefetchValueOp 0 args++-- Atomic read-modify-write+  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_And mba ix (bWord dflags) n+  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opAllDone $ \[res] -> do+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opAllDone $ \[res] -> do+    doAtomicReadByteArray res mba ix (bWord dflags)+  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opAllDone $ \[] -> do+    doAtomicWriteByteArray mba ix (bWord dflags) val+  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opAllDone $ \[res] -> do+    doCasByteArray res mba ix (bWord dflags) old new++-- The rest just translate straightforwardly++  Int2WordOp      -> \args -> opNop args+  Word2IntOp      -> \args -> opNop args+  Int2AddrOp      -> \args -> opNop args+  Addr2IntOp      -> \args -> opNop args+  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same+  OrdOp           -> \args -> opNop args++  Narrow8IntOp   -> \args -> opNarrow dflags args (MO_SS_Conv, W8)+  Narrow16IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W16)+  Narrow32IntOp  -> \args -> opNarrow dflags args (MO_SS_Conv, W32)+  Narrow8WordOp  -> \args -> opNarrow dflags args (MO_UU_Conv, W8)+  Narrow16WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W16)+  Narrow32WordOp -> \args -> opNarrow dflags args (MO_UU_Conv, W32)++  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr+  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin+  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos+  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan+  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh+  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh+  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh+  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin+  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos+  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan+  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh+  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh+  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh+  DoubleLogOp    -> \args -> opCallish args MO_F64_Log+  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P+  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp+  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1+  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt++  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr+  FloatSinOp     -> \args -> opCallish args MO_F32_Sin+  FloatCosOp     -> \args -> opCallish args MO_F32_Cos+  FloatTanOp     -> \args -> opCallish args MO_F32_Tan+  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh+  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh+  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh+  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin+  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos+  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan+  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh+  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh+  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh+  FloatLogOp     -> \args -> opCallish args MO_F32_Log+  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P+  FloatExpOp     -> \args -> opCallish args MO_F32_Exp+  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1+  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt++-- Native word signless ops++  IntAddOp       -> \args -> opTranslate args (mo_wordAdd dflags)+  IntSubOp       -> \args -> opTranslate args (mo_wordSub dflags)+  WordAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)+  WordSubOp      -> \args -> opTranslate args (mo_wordSub dflags)+  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd dflags)+  AddrSubOp      -> \args -> opTranslate args (mo_wordSub dflags)++  IntEqOp        -> \args -> opTranslate args (mo_wordEq dflags)+  IntNeOp        -> \args -> opTranslate args (mo_wordNe dflags)+  WordEqOp       -> \args -> opTranslate args (mo_wordEq dflags)+  WordNeOp       -> \args -> opTranslate args (mo_wordNe dflags)+  AddrEqOp       -> \args -> opTranslate args (mo_wordEq dflags)+  AddrNeOp       -> \args -> opTranslate args (mo_wordNe dflags)++  AndOp          -> \args -> opTranslate args (mo_wordAnd dflags)+  OrOp           -> \args -> opTranslate args (mo_wordOr dflags)+  XorOp          -> \args -> opTranslate args (mo_wordXor dflags)+  NotOp          -> \args -> opTranslate args (mo_wordNot dflags)+  SllOp          -> \args -> opTranslate args (mo_wordShl dflags)+  SrlOp          -> \args -> opTranslate args (mo_wordUShr dflags)++  AddrRemOp      -> \args -> opTranslate args (mo_wordURem dflags)++-- Native word signed ops++  IntMulOp        -> \args -> opTranslate args (mo_wordMul dflags)+  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth dflags))+  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot dflags)+  IntRemOp        -> \args -> opTranslate args (mo_wordSRem dflags)+  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg dflags)++  IntGeOp        -> \args -> opTranslate args (mo_wordSGe dflags)+  IntLeOp        -> \args -> opTranslate args (mo_wordSLe dflags)+  IntGtOp        -> \args -> opTranslate args (mo_wordSGt dflags)+  IntLtOp        -> \args -> opTranslate args (mo_wordSLt dflags)++  AndIOp         -> \args -> opTranslate args (mo_wordAnd dflags)+  OrIOp          -> \args -> opTranslate args (mo_wordOr dflags)+  XorIOp         -> \args -> opTranslate args (mo_wordXor dflags)+  NotIOp         -> \args -> opTranslate args (mo_wordNot dflags)+  ISllOp         -> \args -> opTranslate args (mo_wordShl dflags)+  ISraOp         -> \args -> opTranslate args (mo_wordSShr dflags)+  ISrlOp         -> \args -> opTranslate args (mo_wordUShr dflags)++-- Native word unsigned ops++  WordGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)+  WordLeOp       -> \args -> opTranslate args (mo_wordULe dflags)+  WordGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)+  WordLtOp       -> \args -> opTranslate args (mo_wordULt dflags)++  WordMulOp      -> \args -> opTranslate args (mo_wordMul dflags)+  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot dflags)+  WordRemOp      -> \args -> opTranslate args (mo_wordURem dflags)++  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe dflags)+  AddrLeOp       -> \args -> opTranslate args (mo_wordULe dflags)+  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt dflags)+  AddrLtOp       -> \args -> opTranslate args (mo_wordULt dflags)++-- Int8# signed ops++  Int8Extend     -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth dflags))+  Int8Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W8)+  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)+  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)+  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)+  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)+  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)+  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)++  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)+  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)+  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)+  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)+  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)+  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)++-- Word8# unsigned ops++  Word8Extend     -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth dflags))+  Word8Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W8)+  Word8NotOp      -> \args -> opTranslate args (MO_Not W8)+  Word8AddOp      -> \args -> opTranslate args (MO_Add W8)+  Word8SubOp      -> \args -> opTranslate args (MO_Sub W8)+  Word8MulOp      -> \args -> opTranslate args (MO_Mul W8)+  Word8QuotOp     -> \args -> opTranslate args (MO_U_Quot W8)+  Word8RemOp      -> \args -> opTranslate args (MO_U_Rem W8)++  Word8EqOp       -> \args -> opTranslate args (MO_Eq W8)+  Word8GeOp       -> \args -> opTranslate args (MO_U_Ge W8)+  Word8GtOp       -> \args -> opTranslate args (MO_U_Gt W8)+  Word8LeOp       -> \args -> opTranslate args (MO_U_Le W8)+  Word8LtOp       -> \args -> opTranslate args (MO_U_Lt W8)+  Word8NeOp       -> \args -> opTranslate args (MO_Ne W8)++-- Int16# signed ops++  Int16Extend     -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth dflags))+  Int16Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth dflags) W16)+  Int16NegOp      -> \args -> opTranslate args (MO_S_Neg W16)+  Int16AddOp      -> \args -> opTranslate args (MO_Add W16)+  Int16SubOp      -> \args -> opTranslate args (MO_Sub W16)+  Int16MulOp      -> \args -> opTranslate args (MO_Mul W16)+  Int16QuotOp     -> \args -> opTranslate args (MO_S_Quot W16)+  Int16RemOp      -> \args -> opTranslate args (MO_S_Rem W16)++  Int16EqOp       -> \args -> opTranslate args (MO_Eq W16)+  Int16GeOp       -> \args -> opTranslate args (MO_S_Ge W16)+  Int16GtOp       -> \args -> opTranslate args (MO_S_Gt W16)+  Int16LeOp       -> \args -> opTranslate args (MO_S_Le W16)+  Int16LtOp       -> \args -> opTranslate args (MO_S_Lt W16)+  Int16NeOp       -> \args -> opTranslate args (MO_Ne W16)++-- Word16# unsigned ops++  Word16Extend     -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth dflags))+  Word16Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth dflags) W16)+  Word16NotOp      -> \args -> opTranslate args (MO_Not W16)+  Word16AddOp      -> \args -> opTranslate args (MO_Add W16)+  Word16SubOp      -> \args -> opTranslate args (MO_Sub W16)+  Word16MulOp      -> \args -> opTranslate args (MO_Mul W16)+  Word16QuotOp     -> \args -> opTranslate args (MO_U_Quot W16)+  Word16RemOp      -> \args -> opTranslate args (MO_U_Rem W16)++  Word16EqOp       -> \args -> opTranslate args (MO_Eq W16)+  Word16GeOp       -> \args -> opTranslate args (MO_U_Ge W16)+  Word16GtOp       -> \args -> opTranslate args (MO_U_Gt W16)+  Word16LeOp       -> \args -> opTranslate args (MO_U_Le W16)+  Word16LtOp       -> \args -> opTranslate args (MO_U_Lt W16)+  Word16NeOp       -> \args -> opTranslate args (MO_Ne W16)++-- Char# ops++  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth dflags))+  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth dflags))+  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth dflags))+  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth dflags))+  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth dflags))+  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth dflags))++-- Double ops++  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)+  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)+  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)+  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)+  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)+  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)++  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)+  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)+  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)+  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)+  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)++-- Float ops++  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)+  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)+  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)+  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)+  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)+  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)++  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)+  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)+  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)+  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)+  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)++-- Vector ops++  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)+  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)+  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)+  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)+  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)++  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)+  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)+  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)+  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)+  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)+  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)++  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)+  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)+  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)+  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)+  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)+  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"++-- Conversions++  Int2DoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W64)+  Double2IntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth dflags))++  Int2FloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth dflags) W32)+  Float2IntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth dflags))++  Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)+  Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)++-- Word comparisons masquerading as more exotic things.++  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq dflags)+  SameMVarOp              -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq dflags)+  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq dflags)+  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq dflags)+  SameTVarOp              -> \args -> opTranslate args (mo_wordEq dflags)+  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq dflags)+-- See Note [Comparing stable names]+  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq dflags)++  IntQuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem  (wordWidth dflags))+    else Right (genericIntQuotRemOp (wordWidth dflags))++  Int8QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W8)+    else Right (genericIntQuotRemOp W8)++  Int16QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W16)+    else Right (genericIntQuotRemOp W16)++  WordQuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem  (wordWidth dflags))+    else Right (genericWordQuotRemOp (wordWidth dflags))++  WordQuotRem2Op -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_U_QuotRem2 (wordWidth dflags))+    else Right (genericWordQuotRem2Op dflags)++  Word8QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W8)+    else Right (genericWordQuotRemOp W8)++  Word16QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W16)+    else Right (genericWordQuotRemOp W16)++  WordAdd2Op -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_Add2       (wordWidth dflags))+    else Right genericWordAdd2Op++  WordAddCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddWordC   (wordWidth dflags))+    else Right genericWordAddCOp++  WordSubCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubWordC   (wordWidth dflags))+    else Right genericWordSubCOp++  IntAddCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddIntC    (wordWidth dflags))+    else Right genericIntAddCOp++  IntSubCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubIntC    (wordWidth dflags))+    else Right genericIntSubCOp++  WordMul2Op -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) || llvm+    then Left (MO_U_Mul2     (wordWidth dflags))+    else Right genericWordMul2Op++  IntMul2Op  -> \args -> opCallishHandledLater args $+    if ncg && x86ish+    then Left (MO_S_Mul2     (wordWidth dflags))+    else Right genericIntMul2Op++  FloatFabsOp -> \args -> opCallishHandledLater args $+    if (ncg && x86ish || ppc) || llvm+    then Left MO_F32_Fabs+    else Right $ genericFabsOp W32++  DoubleFabsOp -> \args -> opCallishHandledLater args $+    if (ncg && x86ish || ppc) || llvm+    then Left MO_F64_Fabs+    else Right $ genericFabsOp W64++  -- tagToEnum# is special: we need to pull the constructor+  -- out of the table, and perform an appropriate return.+  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Raw $ \res_ty -> do+    -- If you're reading this code in the attempt to figure+    -- out why the compiler panic'ed here, it is probably because+    -- you used tagToEnum# in a non-monomorphic setting, e.g.,+    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+    -- That won't work.+    let tycon = tyConAppTyCon res_ty+    MASSERT(isEnumerationTyCon tycon)+    dflags <- getDynFlags+    pure [tagToClosure dflags tycon amode]++-- Out of line primops.+-- TODO compiler need not know about these++  UnsafeThawArrayOp -> alwaysExternal+  CasArrayOp -> alwaysExternal+  UnsafeThawSmallArrayOp -> alwaysExternal+  CasSmallArrayOp -> alwaysExternal+  NewPinnedByteArrayOp_Char -> alwaysExternal+  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal+  MutableByteArrayIsPinnedOp -> alwaysExternal+  DoubleDecode_2IntOp -> alwaysExternal+  DoubleDecode_Int64Op -> alwaysExternal+  FloatDecode_IntOp -> alwaysExternal+  ByteArrayIsPinnedOp -> alwaysExternal+  ShrinkMutableByteArrayOp_Char -> alwaysExternal+  ResizeMutableByteArrayOp_Char -> alwaysExternal+  ShrinkSmallMutableArrayOp_Char -> alwaysExternal+  NewArrayArrayOp -> alwaysExternal+  NewMutVarOp -> alwaysExternal+  AtomicModifyMutVar2Op -> alwaysExternal+  AtomicModifyMutVar_Op -> alwaysExternal+  CasMutVarOp -> alwaysExternal+  CatchOp -> alwaysExternal+  RaiseOp -> alwaysExternal+  RaiseIOOp -> alwaysExternal+  MaskAsyncExceptionsOp -> alwaysExternal+  MaskUninterruptibleOp -> alwaysExternal+  UnmaskAsyncExceptionsOp -> alwaysExternal+  MaskStatus -> alwaysExternal+  AtomicallyOp -> alwaysExternal+  RetryOp -> alwaysExternal+  CatchRetryOp -> alwaysExternal+  CatchSTMOp -> alwaysExternal+  NewTVarOp -> alwaysExternal+  ReadTVarOp -> alwaysExternal+  ReadTVarIOOp -> alwaysExternal+  WriteTVarOp -> alwaysExternal+  NewMVarOp -> alwaysExternal+  TakeMVarOp -> alwaysExternal+  TryTakeMVarOp -> alwaysExternal+  PutMVarOp -> alwaysExternal+  TryPutMVarOp -> alwaysExternal+  ReadMVarOp -> alwaysExternal+  TryReadMVarOp -> alwaysExternal+  IsEmptyMVarOp -> alwaysExternal+  DelayOp -> alwaysExternal+  WaitReadOp -> alwaysExternal+  WaitWriteOp -> alwaysExternal+  ForkOp -> alwaysExternal+  ForkOnOp -> alwaysExternal+  KillThreadOp -> alwaysExternal+  YieldOp -> alwaysExternal+  LabelThreadOp -> alwaysExternal+  IsCurrentThreadBoundOp -> alwaysExternal+  NoDuplicateOp -> alwaysExternal+  ThreadStatusOp -> alwaysExternal+  MkWeakOp -> alwaysExternal+  MkWeakNoFinalizerOp -> alwaysExternal+  AddCFinalizerToWeakOp -> alwaysExternal+  DeRefWeakOp -> alwaysExternal+  FinalizeWeakOp -> alwaysExternal+  MakeStablePtrOp -> alwaysExternal+  DeRefStablePtrOp -> alwaysExternal+  MakeStableNameOp -> alwaysExternal+  CompactNewOp -> alwaysExternal+  CompactResizeOp -> alwaysExternal+  CompactContainsOp -> alwaysExternal+  CompactContainsAnyOp -> alwaysExternal+  CompactGetFirstBlockOp -> alwaysExternal+  CompactGetNextBlockOp -> alwaysExternal+  CompactAllocateBlockOp -> alwaysExternal+  CompactFixupPointersOp -> alwaysExternal+  CompactAdd -> alwaysExternal+  CompactAddWithSharing -> alwaysExternal+  CompactSize -> alwaysExternal+  SeqOp -> alwaysExternal+  GetSparkOp -> alwaysExternal+  NumSparks -> alwaysExternal+  DataToTagOp -> alwaysExternal+  MkApUpd0_Op -> alwaysExternal+  NewBCOOp -> alwaysExternal+  UnpackClosureOp -> alwaysExternal+  ClosureSizeOp -> alwaysExternal+  GetApStackValOp -> alwaysExternal+  ClearCCSOp -> alwaysExternal+  TraceEventOp -> alwaysExternal+  TraceEventBinaryOp -> alwaysExternal+  TraceMarkerOp -> alwaysExternal+  SetThreadAllocationCounter -> alwaysExternal++ where+  alwaysExternal = \_ -> PrimopCmmEmit_External+  -- Note [QuotRem optimization]+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+  --+  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops+  -- (shift, .&.).+  --+  -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the+  -- constant is a power of 2. #9041 tracks the implementation of the general+  -- optimization.+  --+  -- `quotRem` can be optimized in the same way. However as it returns two values,+  -- it is implemented as a "callish" primop which is harder to match and+  -- to transform later on. For simplicity, the current implementation detects cases+  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem+  -- primop into two CMM quot and rem primops.+  quotRemCanBeOptimized = \case+    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)+    _                         -> False++  ncg = case hscTarget dflags of+           HscAsm -> True+           _      -> False+  llvm = case hscTarget dflags of+           HscLlvm -> True+           _       -> False+  x86ish = case platformArch (targetPlatform dflags) of+             ArchX86    -> True+             ArchX86_64 -> True+             _          -> False+  ppc = case platformArch (targetPlatform dflags) of+          ArchPPC      -> True+          ArchPPC_64 _ -> True+          _            -> False++data PrimopCmmEmit+  = PrimopCmmEmit_External+  | PrimopCmmEmit_IntoRegs ([LocalReg] -- where to put the results+                           -> FCode ())+  -- | Manual escape hatch, this is just for the '@TagToEnum@'+  -- primop for now. It would be nice to remove this special case but that is+  -- future work.+  | PrimopCmmEmit_Raw (Type -- the return type, some primops are specialized to it+                       -> FCode [CmmExpr]) -- just for TagToEnum for now++opNop :: [CmmExpr] -> PrimopCmmEmit+opNop args = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) arg+  where [arg] = args++opNarrow+  :: DynFlags+  -> [CmmExpr]+  -> (Width -> Width -> MachOp, Width)+  -> PrimopCmmEmit+opNarrow dflags args (mop, rep) = PrimopCmmEmit_IntoRegs $ \[res] -> emitAssign (CmmLocal res) $+  CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]+  where [arg] = args++-- | These primops are implemented by CallishMachOps, because they sometimes+-- turn into foreign calls depending on the backend.+opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit+opCallish args prim = PrimopCmmEmit_IntoRegs $ \[res] -> emitPrimCall [res] prim args++opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit+opTranslate args mop = PrimopCmmEmit_IntoRegs $ \[res] -> do+  let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)+  emit stmt++-- | Basically a "manual" case, rather than one of the common repetitive forms+-- above. The results are a parameter to the returned function so we know the+-- choice of variant never depends on them.+opCallishHandledLater+  :: [CmmExpr]+  -> Either CallishMachOp GenericOp+  -> PrimopCmmEmit+opCallishHandledLater args callOrNot = PrimopCmmEmit_IntoRegs $ \res0 -> case callOrNot of+  Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args+  Right gen -> gen res0 args++opAllDone+  :: ([LocalReg] -- where to put the results+      -> FCode ())+  -> PrimopCmmEmit+opAllDone f = PrimopCmmEmit_IntoRegs $ f++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++genericIntQuotRemOp :: Width -> GenericOp+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: Width -> GenericOp+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++genericWordQuotRem2Op :: DynFlags -> GenericOp+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low+    where    ty = cmmExprType dflags arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]+             zero   = lit 0+             one    = lit 1+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)+             lit i = CmmLit (CmmInt i (wordWidth dflags))++             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>+                                      mkAssign (CmmLocal res_r) high)+             f i acc high low =+                 do roverflowedBit <- newTemp ty+                    rhigh'         <- newTemp ty+                    rhigh''        <- newTemp ty+                    rlow'          <- newTemp ty+                    risge          <- newTemp ty+                    racc'          <- newTemp ty+                    let high'         = CmmReg (CmmLocal rhigh')+                        isge          = CmmReg (CmmLocal risge)+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)+                    let this = catAGraphs+                               [mkAssign (CmmLocal roverflowedBit)+                                          (shr high negone),+                                mkAssign (CmmLocal rhigh')+                                          (or (shl high one) (shr low negone)),+                                mkAssign (CmmLocal rlow')+                                          (shl low one),+                                mkAssign (CmmLocal risge)+                                          (or (overflowedBit `ne` zero)+                                              (high' `ge` arg_y)),+                                mkAssign (CmmLocal rhigh'')+                                          (high' `minus` (arg_y `times` isge)),+                                mkAssign (CmmLocal racc')+                                          (or (shl acc one) isge)]+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))+                                      (CmmReg (CmmLocal rhigh''))+                                      (CmmReg (CmmLocal rlow'))+                    return (this <*> rest)+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do dflags <- getDynFlags+       r1 <- newTemp (cmmExprType dflags arg_x)+       r2 <- newTemp (cmmExprType dflags arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                                (wordWidth dflags))+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:+--+-- @+--    c = a&b | (a|b)&~r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordAddCOp :: GenericOp+genericWordAddCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [aa,bb],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [aa,bb],+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordAddCOp _ _ = panic "genericWordAddCOp"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:+--+-- @+--    c = ~a&b | (~a|b)&r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordNot dflags) [aa],+                bb+              ],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [+                  CmmMachOp (mo_wordNot dflags) [aa],+                  bb+                ],+                CmmReg (CmmLocal res_r)+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordXor dflags) [aa,bb],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      let t = cmmExprType dflags arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                               (wordWidth dflags))+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (sum [topHalf    (CmmReg xlyl),+                        bottomHalf (CmmReg xhyl),+                        bottomHalf (CmmReg xlyh)]),+              mkAssign (CmmLocal res_l)+                  (or (bottomHalf (CmmReg xlyl))+                      (toTopHalf (CmmReg r))),+              mkAssign (CmmLocal res_h)+                  (sum [mul (topHalf arg_x) (topHalf arg_y),+                        topHalf (CmmReg xhyl),+                        topHalf (CmmReg xlyh),+                        topHalf (CmmReg r)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++genericIntMul2Op :: GenericOp+genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174+      let t = cmmExprType dflags arg_x+      p   <- newTemp t+      -- 1) compute the multiplication as if numbers were unsigned+      let wordMul2 = case emitPrimOp dflags WordMul2Op [arg_x,arg_y] of+            PrimopCmmEmit_External -> panic "Unsupported out-of-line WordMul2Op"+            PrimopCmmEmit_IntoRegs f -> f+            PrimopCmmEmit_Raw _ -> panic "Unsupported inline WordMul2Op"+      wordMul2 [p,res_l]+      -- 2) correct the high bits of the unsigned result+      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]+          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]+          and x y     = CmmMachOp (MO_And   ww) [x, y]+          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]+          f   x y     = (carryFill x) `and` y+          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)+          rl x        = CmmReg (CmmLocal x)+          ww          = wordWidth dflags+      emit $ catAGraphs+             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)+             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))+             ]+genericIntMul2Op _ _ = panic "genericIntMul2Op"++-- This replicates what we had in libraries/base/GHC/Float.hs:+--+--    abs x    | x == 0    = 0 -- handles (-0.0)+--             | x >  0    = x+--             | otherwise = negateFloat x+genericFabsOp :: Width -> GenericOp+genericFabsOp w [res_r] [aa]+ = do dflags <- getDynFlags+      let zero   = CmmLit (CmmFloat 0 w)++          eq x y = CmmMachOp (MO_F_Eq w) [x, y]+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]++          neg x  = CmmMachOp (MO_F_Neg w) [x]++          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]++      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)+      let g3 = catAGraphs [mkAssign res_t aa,+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]++      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3++      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4++genericFabsOp _ _ _ = panic "genericFabsOp"++-- Note [Comparing stable names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- A StableName# is actually a pointer to a stable name object (SNO)+-- containing an index into the stable name table (SNT). We+-- used to compare StableName#s by following the pointers to the+-- SNOs and checking whether they held the same SNT indices. However,+-- this is not necessary: there is a one-to-one correspondence+-- between SNOs and entries in the SNT, so simple pointer equality+-- does the trick.++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = do dflags <- getDynFlags+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do dflags <- getDynFlags+       let ty = cmmExprType dflags val+           hdr_size = arrPtrsHdrSize dflags+       -- Update remembered set for non-moving collector+       whenUpdRemSetEnabled dflags+           $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       emitPrimCall [] MO_WriteBarrier []+       mkBasicIndexedWrite hdr_size Nothing addr ty idx val+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+       -- the write barrier.  We must write a byte into the mark table:+       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr dflags+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)+                         (loadArrPtrsSize dflags addr))+          (CmmMachOp (mo_wordUShr dflags) [idx,+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])+         ) (CmmLit (CmmInt 1 W8))++loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags++mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead off Nothing ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (CmmMachOp cast [+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])++mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes+                    -> Maybe MachOp -- Optional value cast+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite off Nothing base idx_ty idx val+   = do dflags <- getDynFlags+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val+mkBasicIndexedWrite off (Just cast) base idx_ty idx val+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: DynFlags+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr dflags off width base idx+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx++cmmLoadIndexOffExpr :: DynFlags+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr dflags off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecVmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _      FloatVec _   =  Nothing+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      IntVec   W64 =  Nothing+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      WordVec  W64 =  Nothing+vecElemInjectCast _      _        _   =  Nothing++vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _      FloatVec _   =  Nothing+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)+vecElemProjectCast _      IntVec   W64 =  Nothing+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)+vecElemProjectCast _      WordVec  W64 =  Nothing+vecElemProjectCast _      _        _   =  Nothing+++-- NOTE [SIMD Design for the future]+-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+-- Currently these checks are specific to x86 and x86_64 architecture.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurements is the only only way to validate that. --      In some next generation CPU ISAs, notably RISC V, the SIMD extension --    includes  support for a sort of run time CPU dependent vectorization parameter, --    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...
compiler/GHC/StgToCmm/Prof.hs view
@@ -28,12 +28,12 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad-import SMRep+import GHC.Runtime.Layout -import MkGraph-import Cmm-import CmmUtils-import CLabel+import GHC.Cmm.Graph+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.CLabel  import CostCentre import DynFlags
compiler/GHC/StgToCmm/Ticky.hs view
@@ -23,9 +23,9 @@    * some codeGen/ modules import this one -  * this module imports cmm/CLabel.hs to manage labels+  * this module imports GHC.Cmm.CLabel to manage labels -  * cmm/CmmParse.y expands some macros using generators defined in+  * GHC.Cmm.Parser expands some macros using generators defined in     this module    * includes/stg/Ticky.h declares all of the global counters@@ -112,11 +112,11 @@ import GHC.StgToCmm.Monad  import GHC.Stg.Syntax-import CmmExpr-import MkGraph-import CmmUtils-import CLabel-import SMRep+import GHC.Cmm.Expr+import GHC.Cmm.Graph+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Runtime.Layout  import Module import Name@@ -517,7 +517,7 @@   ----------------------------------------------------------------------------------- these three are only called from CmmParse.y (ie ultimately from the RTS)+-- these three are only called from GHC.Cmm.Parser (ie ultimately from the RTS)  -- the units are bytes
compiler/GHC/StgToCmm/Utils.hs view
@@ -52,20 +52,20 @@  import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure-import Cmm-import BlockId-import MkGraph+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Graph as CmmGraph import GHC.Platform.Regs-import CLabel-import CmmUtils-import CmmSwitch+import GHC.Cmm.CLabel+import GHC.Cmm.Utils+import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils  import ForeignCall import IdInfo import Type import TyCon-import SMRep+import GHC.Runtime.Layout import Module import Literal import Digraph@@ -458,8 +458,8 @@         -- In that situation we can be sure the (:) case         -- can't happen, so no need to test --- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans--- See Note [Cmm Switches, the general plan] in CmmSwitch+-- SOMETHING MORE COMPLICATED: defer to GHC.Cmm.Switch.Implement+-- See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch mk_discrete_switch signed tag_expr branches mb_deflt range   = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches) @@ -568,7 +568,7 @@ -- and returns L label_code join_lbl (code,tsc) = do     lbl <- newBlockId-    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)+    emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc)     return lbl  --------------
compiler/GHC/ThToHs.hs view
@@ -12,6 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ module GHC.ThToHs    ( convertToHsExpr    , convertToPat@@ -1074,7 +1077,7 @@   UInfixE x * (UInfixE y + z) ---> (x * y) + z  This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and-@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely+@mkHsOpTyRn@ in GHC.Rename.Types), which expects that the input will be completely right-biased for types and left-biased for everything else. So we left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. @@ -1966,7 +1969,7 @@ the way System Names are printed.  There's a small complication of course; see Note [Looking up Exact-RdrNames] in RnEnv.+RdrNames] in GHC.Rename.Env. -}  {-
compiler/backpack/DriverBkp.hs view
@@ -43,7 +43,7 @@ import Outputable import Maybes import HeaderInfo-import MkIface+import GHC.Iface.Utils import GhcMake import UniqDSet import PrelNames@@ -190,7 +190,7 @@         importPaths = [],         -- Synthesized the flags         packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->-          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)+          let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)           in ExposePackage             (showSDoc dflags                 (text "-unit-id" <+> ppr uid <+> ppr rn))@@ -271,7 +271,7 @@      dflags <- getDynFlags     -- IMPROVE IT-    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0+    let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0      mb_old_eps <- case session of                     TcSession -> fmap Just getEpsGhc@@ -375,20 +375,19 @@         ok <- load' LoadAllTargets (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -addPackage :: GhcMonad m => PackageConfig -> m ()+-- | Register a new virtual package database containing a single unit+addPackage :: GhcMonad m => UnitInfo -> m () addPackage pkg = do-    dflags0 <- GHC.getSessionDynFlags-    case pkgDatabase dflags0 of+    dflags <- GHC.getSessionDynFlags+    case pkgDatabase dflags of         Nothing -> panic "addPackage: called too early"-        Just pkgs -> do let dflags = dflags0 { pkgDatabase =-                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }-                        _ <- GHC.setSessionDynFlags dflags-                        -- By this time, the global ref has probably already-                        -- been forced, in which case doing this isn't actually-                        -- going to do you any good.-                        -- dflags <- GHC.getSessionDynFlags-                        -- liftIO $ setUnsafeGlobalDynFlags dflags-                        return ()+        Just dbs -> do+         let newdb = PackageDatabase+               { packageDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"+               , packageDatabaseUnits = [pkg]+               }+         _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })+         return ()  -- Precondition: UnitId is NOT InstalledUnitId compileInclude :: Int -> (Int, UnitId) -> BkpM ()@@ -397,7 +396,7 @@     let dflags = hsc_dflags hsc_env     msgInclude (i, n) uid     -- Check if we've compiled it already-    case lookupPackage dflags uid of+    case lookupUnit dflags uid of         Nothing -> do             case splitUnitIdInsts uid of                 (_, Just indef) ->@@ -711,7 +710,7 @@ summariseDecl :: PackageName               -> HscSource               -> Located ModuleName-              -> Maybe (Located (HsModule GhcPs))+              -> Maybe (Located HsModule)               -> BkpM ModSummary summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing@@ -738,7 +737,7 @@ hsModuleToModSummary :: PackageName                      -> HscSource                      -> ModuleName-                     -> Located (HsModule GhcPs)+                     -> Located HsModule                      -> BkpM ModSummary hsModuleToModSummary pn hsc_src modname                      hsmod = do
compiler/backpack/NameShape.hs view
@@ -25,7 +25,7 @@ import NameEnv import TcRnMonad import Util-import IfaceEnv+import GHC.Iface.Env  import Control.Monad
− compiler/backpack/RnModIface.hs 
@@ -1,743 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}---- | This module implements interface renaming, which is--- used to rewrite interface files on the fly when we--- are doing indefinite typechecking and need instantiations--- of modules which do not necessarily exist yet.--module RnModIface(-    rnModIface,-    rnModExports,-    tcRnModIface,-    tcRnModExports,-    ) where--#include "HsVersions.h"--import GhcPrelude--import SrcLoc-import Outputable-import HscTypes-import Module-import UniqFM-import Avail-import IfaceSyn-import FieldLabel-import Var-import ErrUtils--import Name-import TcRnMonad-import Util-import Fingerprint-import BasicTypes---- a bit vexing-import {-# SOURCE #-} LoadIface-import DynFlags--import qualified Data.Traversable as T--import Bag-import Data.IORef-import NameShape-import IfaceEnv--tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a-tcRnMsgMaybe do_this = do-    r <- liftIO $ do_this-    case r of-        Left errs -> do-            addMessages (emptyBag, errs)-            failM-        Right x -> return x--tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface-tcRnModIface x y z = do-    hsc_env <- getTopEnv-    tcRnMsgMaybe $ rnModIface hsc_env x y z--tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]-tcRnModExports x y = do-    hsc_env <- getTopEnv-    tcRnMsgMaybe $ rnModExports hsc_env x y--failWithRn :: SDoc -> ShIfM a-failWithRn doc = do-    errs_var <- fmap sh_if_errs getGblEnv-    dflags <- getDynFlags-    errs <- readTcRef errs_var-    -- TODO: maybe associate this with a source location?-    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)-    failM---- | What we have is a generalized ModIface, which corresponds to--- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.--- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load--- up (either to merge it, or to just use during typechecking).------ Suppose we have:------  p[A=<A>]:M  ==>  p[A=q():A]:M------ Substitute all occurrences of <A> with q():A (renameHoleModule).--- Then, for any Name of form {A.T}, replace the Name with--- the Name according to the exports of the implementing module.--- This works even for p[A=<B>]:M, since we just read in the--- exports of B.hi, which is assumed to be ready now.------ This function takes an optional 'NameShape', which can be used--- to further refine the identities in this interface: suppose--- we read a declaration for {H.T} but we actually know that this--- should be Foo.T; then we'll also rename this (this is used--- when loading an interface to merge it into a requirement.)-rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape-           -> ModIface -> IO (Either ErrorMessages ModIface)-rnModIface hsc_env insts nsubst iface = do-    initRnIface hsc_env iface insts nsubst $ do-        mod <- rnModule (mi_module iface)-        sig_of <- case mi_sig_of iface of-                    Nothing -> return Nothing-                    Just x  -> fmap Just (rnModule x)-        exports <- mapM rnAvailInfo (mi_exports iface)-        decls <- mapM rnIfaceDecl' (mi_decls iface)-        insts <- mapM rnIfaceClsInst (mi_insts iface)-        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)-        deps <- rnDependencies (mi_deps iface)-        -- TODO:-        -- mi_rules-        return iface { mi_module = mod-                     , mi_sig_of = sig_of-                     , mi_insts = insts-                     , mi_fam_insts = fams-                     , mi_exports = exports-                     , mi_decls = decls-                     , mi_deps = deps }---- | Rename just the exports of a 'ModIface'.  Useful when we're doing--- shaping prior to signature merging.-rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])-rnModExports hsc_env insts iface-    = initRnIface hsc_env iface insts Nothing-    $ 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 }--rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]-rnDepModules sel deps = 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-        dflags <- getDynFlags-        -- 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-        -- F, we must grab and include all of the dep_finsts from-        -- F to have an accurate transitive dep_finsts list.-        ---        -- However, we MUST NOT do this for regular modules.-        -- First, for efficiency reasons, doing this-        -- bloats the the dep_finsts list, because we *already* had-        -- those modules in the list (it wasn't a hole module, after-        -- all). But there's a second, more important correctness-        -- consideration: we perform module renaming when running-        -- --abi-hash.  In this case, GHC's contract to the user is that-        -- it will NOT go and read out interfaces of any dependencies-        -- (https://github.com/haskell/cabal/issues/3633); the point of-        -- --abi-hash is just to get a hash of the on-disk interfaces-        -- for this *specific* package.  If we go off and tug on the-        -- interface for /everything/ in dep_finsts, we're gonna have a-        -- bad time.  (It's safe to do do this for hole modules, though,-        -- because the hmap for --abi-hash is always trivial, so the-        -- interface we request is local.  Though, maybe we ought-        -- not to do it in this case either...)-        ---        -- This mistake was bug #15594.-        let mod' = renameHoleModule dflags hmap mod-        if isHoleModule mod-          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env-                                  $ loadSysInterface (text "rnDepModule") mod'-                  return (mod' : sel (mi_deps iface))-          else return [mod']--{--************************************************************************-*                                                                      *-                        ModIface substitution-*                                                                      *-************************************************************************--}---- | Run a computation in the 'ShIfM' monad.-initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape-            -> ShIfM a -> IO (Either ErrorMessages a)-initRnIface hsc_env iface insts nsubst do_this = do-    errs_var <- newIORef emptyBag-    let dflags = hsc_dflags hsc_env-        hsubst = listToUFM insts-        rn_mod = renameHoleModule dflags hsubst-        env = ShIfEnv {-            sh_if_module = rn_mod (mi_module iface),-            sh_if_semantic_module = rn_mod (mi_semantic_module iface),-            sh_if_hole_subst = listToUFM insts,-            sh_if_shape = nsubst,-            sh_if_errs = errs_var-        }-    -- Modeled off of 'initTc'-    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this-    msgs <- readIORef errs_var-    case res of-        Left _                          -> return (Left msgs)-        Right r | not (isEmptyBag msgs) -> return (Left msgs)-                | otherwise             -> return (Right r)---- | Environment for 'ShIfM' monads.-data ShIfEnv = ShIfEnv {-        -- What we are renaming the ModIface to.  It assumed that-        -- the original mi_module of the ModIface is-        -- @generalizeModule (mi_module iface)@.-        sh_if_module :: Module,-        -- The semantic module that we are renaming to-        sh_if_semantic_module :: Module,-        -- Cached hole substitution, e.g.-        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@-        sh_if_hole_subst :: ShHoleSubst,-        -- An optional name substitution to be applied when renaming-        -- the names in the interface.  If this is 'Nothing', then-        -- we just load the target interface and look at the export-        -- list to determine the renaming.-        sh_if_shape :: Maybe NameShape,-        -- Mutable reference to keep track of errors (similar to 'tcl_errs')-        sh_if_errs :: IORef ErrorMessages-    }--getHoleSubst :: ShIfM ShHoleSubst-getHoleSubst = fmap sh_if_hole_subst getGblEnv--type ShIfM = TcRnIf ShIfEnv ()-type Rename a = a -> ShIfM a---rnModule :: Rename Module-rnModule mod = do-    hmap <- getHoleSubst-    dflags <- getDynFlags-    return (renameHoleModule dflags hmap mod)--rnAvailInfo :: Rename AvailInfo-rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n-rnAvailInfo (AvailTC n ns fs) = do-    -- Why don't we rnIfaceGlobal the availName itself?  It may not-    -- actually be exported by the module it putatively is from, in-    -- which case we won't be able to tell what the name actually-    -- is.  But for the availNames they MUST be exported, so they-    -- will rename fine.-    ns' <- mapM rnIfaceGlobal ns-    fs' <- mapM rnFieldLabel fs-    case ns' ++ map flSelector fs' of-        [] -> panic "rnAvailInfoEmpty AvailInfo"-        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do-                         n' <- setNameModule (Just (nameModule rep)) n-                         return (AvailTC n' ns' fs')--rnFieldLabel :: Rename FieldLabel-rnFieldLabel (FieldLabel l b sel) = do-    sel' <- rnIfaceGlobal sel-    return (FieldLabel l b sel')------- | The key function.  This gets called on every Name embedded--- inside a ModIface.  Our job is to take a Name from some--- generalized unit ID p[A=<A>, B=<B>], and change--- it to the correct name for a (partially) instantiated unit--- ID, e.g. p[A=q[]:A, B=<B>].------ There are two important things to do:------ If a hole is substituted with a real module implementation,--- we need to look at that actual implementation to determine what--- the true identity of this name should be.  We'll do this by--- loading that module's interface and looking at the mi_exports.------ However, there is one special exception: when we are loading--- the interface of a requirement.  In this case, we may not have--- the "implementing" interface, because we are reading this--- interface precisely to "merge it in".------     External case:---         p[A=<B>]:A (and thisUnitId is something else)---     We are loading this in order to determine B.hi!  So---     don't load B.hi to find the exports.------     Local case:---         p[A=<A>]:A (and thisUnitId is p[A=<A>])---     This should not happen, because the rename is not necessary---     in this case, but if it does we shouldn't load A.hi!------ Compare me with 'tcIfaceGlobal'!---- In effect, this function needs compute the name substitution on the--- fly.  What it has is the name that we would like to substitute.--- If the name is not a hole name {M.x} (e.g. isHoleModule) then--- no renaming can take place (although the inner hole structure must--- be updated to account for the hole module renaming.)-rnIfaceGlobal :: Name -> ShIfM Name-rnIfaceGlobal n = do-    hsc_env <- getTopEnv-    let dflags = hsc_dflags hsc_env-    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv-    mb_nsubst <- fmap sh_if_shape getGblEnv-    hmap <- getHoleSubst-    let m = nameModule n-        m' = renameHoleModule dflags hmap m-    case () of-       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,-       -- do NOT assume B.hi is available.-       -- In this case, rename {A.T} to {B.T} but don't look up exports.-     _ | m' == iface_semantic_mod-       , isHoleModule m'-      -- NB: this could be Nothing for computeExports, we have-      -- nothing to say.-      -> do n' <- setNameModule (Just m') n-            case mb_nsubst of-                Nothing -> return n'-                Just nsubst ->-                    case maybeSubstNameShape nsubst n' of-                        -- TODO: would love to have context-                        -- TODO: This will give an unpleasant message if n'-                        -- is a constructor; then we'll suggest adding T-                        -- but it won't work.-                        Nothing -> failWithRn $ vcat [-                            text "The identifier" <+> ppr (occName n') <+>-                                text "does not exist in the local signature.",-                            parens (text "Try adding it to the export list of the hsig file.")-                            ]-                        Just n'' -> return n''-       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the-       -- export list is irrelevant.-       | not (isHoleModule m)-      -> setNameModule (Just m') n-       -- The substitution was from <A> to p[]:A.-       -- But this does not mean {A.T} goes to p[]:A.T:-       -- p[]:A may reexport T from somewhere else.  Do the name-       -- substitution.  Furthermore, we need-       -- to make sure we pick the accurate name NOW,-       -- or we might accidentally reject a merge.-       | otherwise-      -> do -- Make sure we look up the local interface if substitution-            -- went from <A> to <B>.-            let m'' = if isHoleModule m'-                        -- Pull out the local guy!!-                        then mkModule (thisPackage dflags) (moduleName m')-                        else m'-            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env-                            $ loadSysInterface (text "rnIfaceGlobal") m''-            let nsubst = mkNameShape (moduleName m) (mi_exports iface)-            case maybeSubstNameShape nsubst n of-                Nothing -> failWithRn $ vcat [-                    text "The identifier" <+> ppr (occName n) <+>-                        -- NB: report m' because it's more user-friendly-                        text "does not exist in the signature for" <+> ppr m',-                    parens (text "Try adding it to the export list in that hsig file.")-                    ]-                Just n' -> return n'---- | Rename an implicit name, e.g., a DFun or coercion axiom.--- Here is where we ensure that DFuns have the correct module as described in--- Note [rnIfaceNeverExported].-rnIfaceNeverExported :: Name -> ShIfM Name-rnIfaceNeverExported name = do-    hmap <- getHoleSubst-    dflags <- getDynFlags-    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv-    let m = renameHoleModule dflags hmap $ nameModule name-    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.-    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )-    setNameModule (Just m) name---- Note [rnIfaceNeverExported]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- For the high-level overview, see--- Note [Handling never-exported TyThings under Backpack]------ When we see a reference to an entity that was defined in a signature,--- 'rnIfaceGlobal' relies on the identifier in question being part of the--- exports of the implementing 'ModIface', so that we can use the exports to--- decide how to rename the identifier.  Unfortunately, references to 'DFun's--- and 'CoAxiom's will run into trouble under this strategy, because they are--- never exported.------ Let us consider first what should happen in the absence of promotion.  In--- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside--- the signature *that is defining it* (as there are no Core terms in--- typechecked-only interface files, there's no way for a reference to occur--- besides from the defining 'ClsInst' or closed type family).  Thus,--- it doesn't really matter what names we give the DFun/CoAxiom, as long--- as it's consistent between the declaration site and the use site.------ We have to make sure that these bogus names don't get propagated,--- but it is fine: see Note [Signature merging DFuns] for the fixups--- to the names we do before writing out the merged interface.--- (It's even easier for instantiation, since the DFuns all get--- dropped entirely; the instances are reexported implicitly.)------ Unfortunately, this strategy is not enough in the presence of promotion--- (see bug #13149), where modules which import the signature may make--- reference to their coercions.  It's not altogether clear how to--- fix this case, but it is definitely a bug!---- PILES AND PILES OF BOILERPLATE---- | Rename an 'IfaceClsInst', with special handling for an associated--- dictionary function.-rnIfaceClsInst :: Rename IfaceClsInst-rnIfaceClsInst cls_inst = do-    n <- rnIfaceGlobal (ifInstCls cls_inst)-    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)--    dfun <- rnIfaceNeverExported (ifDFun cls_inst)-    return cls_inst { ifInstCls = n-                    , ifInstTys = tys-                    , ifDFun = dfun-                    }--rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)-rnMaybeIfaceTyCon Nothing = return Nothing-rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc--rnIfaceFamInst :: Rename IfaceFamInst-rnIfaceFamInst d = do-    fam <- rnIfaceGlobal (ifFamInstFam d)-    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)-    axiom <- rnIfaceGlobal (ifFamInstAxiom d)-    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }--rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)-rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl--rnIfaceDecl :: Rename IfaceDecl-rnIfaceDecl d@IfaceId{} = do-            name <- case ifIdDetails d of-                      IfDFunId -> rnIfaceNeverExported (ifName d)-                      _ | isDefaultMethodOcc (occName (ifName d))-                        -> rnIfaceNeverExported (ifName d)-                      -- Typeable bindings. See Note [Grand plan for Typeable].-                      _ | isTypeableBindOcc (occName (ifName d))-                        -> rnIfaceNeverExported (ifName d)-                        | otherwise -> rnIfaceGlobal (ifName d)-            ty <- rnIfaceType (ifType d)-            details <- rnIfaceIdDetails (ifIdDetails d)-            info <- rnIfaceIdInfo (ifIdInfo d)-            return d { ifName = name-                     , ifType = ty-                     , ifIdDetails = details-                     , ifIdInfo = info-                     }-rnIfaceDecl d@IfaceData{} = do-            name <- rnIfaceGlobal (ifName d)-            binders <- mapM rnIfaceTyConBinder (ifBinders d)-            ctxt <- mapM rnIfaceType (ifCtxt d)-            cons <- rnIfaceConDecls (ifCons d)-            res_kind <- rnIfaceType (ifResKind d)-            parent <- rnIfaceTyConParent (ifParent d)-            return d { ifName = name-                     , ifBinders = binders-                     , ifCtxt = ctxt-                     , ifCons = cons-                     , ifResKind = res_kind-                     , ifParent = parent-                     }-rnIfaceDecl d@IfaceSynonym{} = do-            name <- rnIfaceGlobal (ifName d)-            binders <- mapM rnIfaceTyConBinder (ifBinders d)-            syn_kind <- rnIfaceType (ifResKind d)-            syn_rhs <- rnIfaceType (ifSynRhs d)-            return d { ifName = name-                     , ifBinders = binders-                     , ifResKind = syn_kind-                     , ifSynRhs = syn_rhs-                     }-rnIfaceDecl d@IfaceFamily{} = do-            name <- rnIfaceGlobal (ifName d)-            binders <- mapM rnIfaceTyConBinder (ifBinders d)-            fam_kind <- rnIfaceType (ifResKind d)-            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)-            return d { ifName = name-                     , ifBinders = binders-                     , ifResKind = fam_kind-                     , ifFamFlav = fam_flav-                     }-rnIfaceDecl d@IfaceClass{} = do-            name <- rnIfaceGlobal (ifName d)-            binders <- mapM rnIfaceTyConBinder (ifBinders d)-            body <- rnIfaceClassBody (ifBody d)-            return d { ifName    = name-                     , ifBinders = binders-                     , ifBody    = body-                     }-rnIfaceDecl d@IfaceAxiom{} = do-            name <- rnIfaceNeverExported (ifName d)-            tycon <- rnIfaceTyCon (ifTyCon d)-            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)-            return d { ifName = name-                     , ifTyCon = tycon-                     , ifAxBranches = ax_branches-                     }-rnIfaceDecl d@IfacePatSyn{} =  do-            name <- rnIfaceGlobal (ifName d)-            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b-            pat_matcher <- rnPat (ifPatMatcher d)-            pat_builder <- T.traverse rnPat (ifPatBuilder d)-            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)-            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)-            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)-            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)-            pat_args <- mapM rnIfaceType (ifPatArgs d)-            pat_ty <- rnIfaceType (ifPatTy d)-            return d { ifName = name-                     , ifPatMatcher = pat_matcher-                     , ifPatBuilder = pat_builder-                     , ifPatUnivBndrs = pat_univ_bndrs-                     , ifPatExBndrs = pat_ex_bndrs-                     , ifPatProvCtxt = pat_prov_ctxt-                     , ifPatReqCtxt = pat_req_ctxt-                     , ifPatArgs = pat_args-                     , ifPatTy = pat_ty-                     }--rnIfaceClassBody :: Rename IfaceClassBody-rnIfaceClassBody IfAbstractClass = return IfAbstractClass-rnIfaceClassBody d@IfConcreteClass{} = do-    ctxt <- mapM rnIfaceType (ifClassCtxt d)-    ats <- mapM rnIfaceAT (ifATs d)-    sigs <- mapM rnIfaceClassOp (ifSigs d)-    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }--rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav-rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))-    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n-                                                <*> mapM rnIfaceAxBranch axs)-rnIfaceFamTyConFlav flav = pure flav--rnIfaceAT :: Rename IfaceAT-rnIfaceAT (IfaceAT decl mb_ty)-    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty--rnIfaceTyConParent :: Rename IfaceTyConParent-rnIfaceTyConParent (IfDataInstance n tc args)-    = IfDataInstance <$> rnIfaceGlobal n-                     <*> rnIfaceTyCon tc-                     <*> rnIfaceAppArgs args-rnIfaceTyConParent IfNoParent = pure IfNoParent--rnIfaceConDecls :: Rename IfaceConDecls-rnIfaceConDecls (IfDataTyCon ds)-    = IfDataTyCon <$> mapM rnIfaceConDecl ds-rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d-rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon--rnIfaceConDecl :: Rename IfaceConDecl-rnIfaceConDecl d = do-    con_name <- rnIfaceGlobal (ifConName d)-    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)-    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)-    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t-    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)-    con_ctxt <- mapM rnIfaceType (ifConCtxt d)-    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)-    con_fields <- mapM rnFieldLabel (ifConFields d)-    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co-        rnIfaceBang bang = pure bang-    con_stricts <- mapM rnIfaceBang (ifConStricts d)-    return d { ifConName = con_name-             , ifConExTCvs = con_ex_tvs-             , ifConUserTvBinders = con_user_tvbs-             , ifConEqSpec = con_eq_spec-             , ifConCtxt = con_ctxt-             , ifConArgTys = con_arg_tys-             , ifConFields = con_fields-             , ifConStricts = con_stricts-             }--rnIfaceClassOp :: Rename IfaceClassOp-rnIfaceClassOp (IfaceClassOp n ty dm) =-    IfaceClassOp <$> rnIfaceGlobal n-                 <*> rnIfaceType ty-                 <*> rnMaybeDefMethSpec dm--rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))-rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty-rnMaybeDefMethSpec mb = return mb--rnIfaceAxBranch :: Rename IfaceAxBranch-rnIfaceAxBranch d = do-    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)-    lhs <- rnIfaceAppArgs (ifaxbLHS d)-    rhs <- rnIfaceType (ifaxbRHS d)-    return d { ifaxbTyVars = ty_vars-             , ifaxbLHS = lhs-             , ifaxbRHS = rhs }--rnIfaceIdInfo :: Rename IfaceIdInfo-rnIfaceIdInfo NoInfo = pure NoInfo-rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is--rnIfaceInfoItem :: Rename IfaceInfoItem-rnIfaceInfoItem (HsUnfold lb if_unf)-    = HsUnfold lb <$> rnIfaceUnfolding if_unf-rnIfaceInfoItem i-    = pure i--rnIfaceUnfolding :: Rename IfaceUnfolding-rnIfaceUnfolding (IfCoreUnfold stable if_expr)-    = IfCoreUnfold stable <$> rnIfaceExpr if_expr-rnIfaceUnfolding (IfCompulsory if_expr)-    = IfCompulsory <$> rnIfaceExpr if_expr-rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)-    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr-rnIfaceUnfolding (IfDFunUnfold bs ops)-    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops--rnIfaceExpr :: Rename IfaceExpr-rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)-rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl-rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty-rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co-rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args-rnIfaceExpr (IfaceLam lam_bndr expr)-    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr-rnIfaceExpr (IfaceApp fun arg)-    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg-rnIfaceExpr (IfaceCase scrut case_bndr alts)-    = IfaceCase <$> rnIfaceExpr scrut-                <*> pure case_bndr-                <*> mapM rnIfaceAlt alts-rnIfaceExpr (IfaceECase scrut ty)-    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty-rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)-    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)-               <*> rnIfaceExpr body-rnIfaceExpr (IfaceLet (IfaceRec pairs) body)-    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->-                                        (,) <$> rnIfaceLetBndr bndr-                                            <*> rnIfaceExpr rhs) pairs)-               <*> rnIfaceExpr body-rnIfaceExpr (IfaceCast expr co)-    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co-rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)-rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty-rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr--rnIfaceBndrs :: Rename [IfaceBndr]-rnIfaceBndrs = mapM rnIfaceBndr--rnIfaceBndr :: Rename IfaceBndr-rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)-rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr--rnIfaceTvBndr :: Rename IfaceTvBndr-rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind--rnIfaceTyConBinder :: Rename IfaceTyConBinder-rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis--rnIfaceAlt :: Rename IfaceAlt-rnIfaceAlt (conalt, names, rhs)-     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs--rnIfaceConAlt :: Rename IfaceConAlt-rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ-rnIfaceConAlt alt = pure alt--rnIfaceLetBndr :: Rename IfaceLetBndr-rnIfaceLetBndr (IfLetBndr fs ty info jpi)-    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi--rnIfaceLamBndr :: Rename IfaceLamBndr-rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot--rnIfaceMCo :: Rename IfaceMCoercion-rnIfaceMCo IfaceMRefl    = pure IfaceMRefl-rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co--rnIfaceCo :: Rename IfaceCoercion-rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty-rnIfaceCo (IfaceGReflCo role ty mco)-  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco-rnIfaceCo (IfaceFunCo role co1 co2)-    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2-rnIfaceCo (IfaceTyConAppCo role tc cos)-    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos-rnIfaceCo (IfaceAppCo co1 co2)-    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2-rnIfaceCo (IfaceForAllCo bndr co1 co2)-    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2-rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)-rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl-rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl-rnIfaceCo (IfaceAxiomInstCo n i cs)-    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs-rnIfaceCo (IfaceUnivCo s r t1 t2)-    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2-rnIfaceCo (IfaceSymCo c)-    = IfaceSymCo <$> rnIfaceCo c-rnIfaceCo (IfaceTransCo c1 c2)-    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2-rnIfaceCo (IfaceInstCo c1 c2)-    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2-rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c-rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c-rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c-rnIfaceCo (IfaceAxiomRuleCo ax cos)-    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos-rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c--rnIfaceTyCon :: Rename IfaceTyCon-rnIfaceTyCon (IfaceTyCon n info)-    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info--rnIfaceExprs :: Rename [IfaceExpr]-rnIfaceExprs = mapM rnIfaceExpr--rnIfaceIdDetails :: Rename IfaceIdDetails-rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b-rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b-rnIfaceIdDetails details = pure details--rnIfaceType :: Rename IfaceType-rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)-rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)-rnIfaceType (IfaceAppTy t1 t2)-    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2-rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)-rnIfaceType (IfaceFunTy af t1 t2)-    = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2-rnIfaceType (IfaceTupleTy s i tks)-    = IfaceTupleTy s i <$> rnIfaceAppArgs tks-rnIfaceType (IfaceTyConApp tc tks)-    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks-rnIfaceType (IfaceForAllTy tv t)-    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t-rnIfaceType (IfaceCoercionTy co)-    = IfaceCoercionTy <$> rnIfaceCo co-rnIfaceType (IfaceCastTy ty co)-    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co--rnIfaceForAllBndr :: Rename IfaceForAllBndr-rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis--rnIfaceAppArgs :: Rename IfaceAppArgs-rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a-                                        <*> rnIfaceAppArgs ts-rnIfaceAppArgs IA_Nil = pure IA_Nil
− compiler/cmm/Bitmap.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE BangPatterns #-}------- (c) The University of Glasgow 2003-2006------- Functions for constructing bitmaps, which are used in various--- places in generated code (stack frame liveness masks, function--- argument liveness masks, SRT bitmaps).--module Bitmap (-        Bitmap, mkBitmap,-        intsToBitmap, intsToReverseBitmap,-        mAX_SMALL_BITMAP_SIZE,-        seqBitmap,-  ) where--import GhcPrelude--import SMRep-import DynFlags-import Util--import Data.Bits--{-|-A bitmap represented by a sequence of 'StgWord's on the /target/-architecture.  These are used for bitmaps in info tables and other-generated code which need to be emitted as sequences of StgWords.--}-type Bitmap = [StgWord]---- | Make a bitmap from a sequence of bits-mkBitmap :: DynFlags -> [Bool] -> Bitmap-mkBitmap _ [] = []-mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest-  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff--chunkToBitmap :: DynFlags -> [Bool] -> StgWord-chunkToBitmap dflags chunk =-  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]-  where-    oneAt :: Int -> StgWord-    oneAt i = toStgWord dflags 1 `shiftL` i---- | Make a bitmap where the slots specified are the /ones/ in the bitmap.--- eg. @[0,1,3], size 4 ==> 0xb@.------ The list of @Int@s /must/ be already sorted.-intsToBitmap :: DynFlags-             -> Int        -- ^ size in bits-             -> [Int]      -- ^ sorted indices of ones-             -> Bitmap-intsToBitmap dflags size = go 0-  where-    word_sz = wORD_SIZE_IN_BITS dflags-    oneAt :: Int -> StgWord-    oneAt i = toStgWord dflags 1 `shiftL` i--    -- It is important that we maintain strictness here.-    -- See Note [Strictness when building Bitmaps].-    go :: Int -> [Int] -> Bitmap-    go !pos slots-      | size <= pos = []-      | otherwise =-        (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) :-          go (pos + word_sz) rest-      where-        (these,rest) = span (< (pos + word_sz)) slots---- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.--- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,--- just to make the bitmap easier to read).------ The list of @Int@s /must/ be already sorted and duplicate-free.-intsToReverseBitmap :: DynFlags-                    -> Int      -- ^ size in bits-                    -> [Int]    -- ^ sorted indices of zeros free of duplicates-                    -> Bitmap-intsToReverseBitmap dflags size = go 0-  where-    word_sz = wORD_SIZE_IN_BITS dflags-    oneAt :: Int -> StgWord-    oneAt i = toStgWord dflags 1 `shiftL` i--    -- It is important that we maintain strictness here.-    -- See Note [Strictness when building Bitmaps].-    go :: Int -> [Int] -> Bitmap-    go !pos slots-      | size <= pos = []-      | otherwise =-        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :-          go (pos + word_sz) rest-      where-        (these,rest) = span (< (pos + word_sz)) slots-        remain = size - pos-        init-          | remain >= word_sz = -1-          | otherwise         = (1 `shiftL` remain) - 1--{---Note [Strictness when building Bitmaps]-========================================--One of the places where @Bitmap@ is used is in in building Static Reference-Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed-that some test cases (particularly those whose C-- have large numbers of CAFs)-produced large quantities of allocations from this function.--The source traced back to 'intsToBitmap', which was lazily subtracting the word-size from the elements of the tail of the @slots@ list and recursively invoking-itself with the result. This resulted in large numbers of subtraction thunks-being built up. Here we take care to avoid passing new thunks to the recursive-call. Instead we pass the unmodified tail along with an explicit position-accumulator, which get subtracted in the fold when we compute the Word.---}--{- |-Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.-Some kinds of bitmap pack a size\/bitmap into a single word if-possible, or fall back to an external pointer when the bitmap is too-large.  This value represents the largest size of bitmap that can be-packed into a single word.--}-mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int-mAX_SMALL_BITMAP_SIZE dflags- | wORD_SIZE dflags == 4 = 27- | otherwise             = 58--seqBitmap :: Bitmap -> a -> a-seqBitmap = seqList-
− compiler/cmm/BlockId.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{- BlockId module should probably go away completely, being superseded by Label -}-module BlockId-  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet-  , newBlockId-  , blockLbl, infoTblLbl-  ) where--import GhcPrelude--import CLabel-import IdInfo-import Name-import Unique-import UniqSupply--import Hoopl.Label (Label, mkHooplLabel)---------------------------------------------------------------------- Block Ids, their environments, and their sets--{- Note [Unique BlockId]-~~~~~~~~~~~~~~~~~~~~~~~~-Although a 'BlockId' is a local label, for reasons of implementation,-'BlockId's must be unique within an entire compilation unit.  The reason-is that each local label is mapped to an assembly-language label, and in-most assembly languages allow, a label is visible throughout the entire-compilation unit in which it appears.--}--type BlockId = Label--mkBlockId :: Unique -> BlockId-mkBlockId unique = mkHooplLabel $ getKey unique--newBlockId :: MonadUnique m => m BlockId-newBlockId = mkBlockId <$> getUniqueM--blockLbl :: BlockId -> CLabel-blockLbl label = mkLocalBlockLabel (getUnique label)--infoTblLbl :: BlockId -> CLabel-infoTblLbl label-  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
− compiler/cmm/BlockId.hs-boot 
@@ -1,8 +0,0 @@-module BlockId (BlockId, mkBlockId) where--import Hoopl.Label (Label)-import Unique (Unique)--type BlockId = Label--mkBlockId :: Unique -> BlockId
− compiler/cmm/CLabel.hs 
@@ -1,1571 +0,0 @@------------------------------------------------------------------------------------ Object-file symbols (called CLabel for histerical raisins).------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}--module CLabel (-        CLabel, -- abstract type-        ForeignLabelSource(..),-        pprDebugCLabel,--        mkClosureLabel,-        mkSRTLabel,-        mkInfoTableLabel,-        mkEntryLabel,-        mkRednCountsLabel,-        mkConInfoTableLabel,-        mkApEntryLabel,-        mkApInfoTableLabel,-        mkClosureTableLabel,-        mkBytesLabel,--        mkLocalBlockLabel,-        mkLocalClosureLabel,-        mkLocalInfoTableLabel,-        mkLocalClosureTableLabel,--        mkBlockInfoTableLabel,--        mkBitmapLabel,-        mkStringLitLabel,--        mkAsmTempLabel,-        mkAsmTempDerivedLabel,-        mkAsmTempEndLabel,-        mkAsmTempDieLabel,--        mkDirty_MUT_VAR_Label,-        mkNonmovingWriteBarrierEnabledLabel,-        mkUpdInfoLabel,-        mkBHUpdInfoLabel,-        mkIndStaticInfoLabel,-        mkMainCapabilityLabel,-        mkMAP_FROZEN_CLEAN_infoLabel,-        mkMAP_FROZEN_DIRTY_infoLabel,-        mkMAP_DIRTY_infoLabel,-        mkSMAP_FROZEN_CLEAN_infoLabel,-        mkSMAP_FROZEN_DIRTY_infoLabel,-        mkSMAP_DIRTY_infoLabel,-        mkBadAlignmentLabel,-        mkArrWords_infoLabel,-        mkSRTInfoLabel,--        mkTopTickyCtrLabel,-        mkCAFBlackHoleInfoTableLabel,-        mkRtsPrimOpLabel,-        mkRtsSlowFastTickyCtrLabel,--        mkSelectorInfoLabel,-        mkSelectorEntryLabel,--        mkCmmInfoLabel,-        mkCmmEntryLabel,-        mkCmmRetInfoLabel,-        mkCmmRetLabel,-        mkCmmCodeLabel,-        mkCmmDataLabel,-        mkCmmClosureLabel,--        mkRtsApFastLabel,--        mkPrimCallLabel,--        mkForeignLabel,-        addLabelSize,--        foreignLabelStdcallInfo,-        isBytesLabel,-        isForeignLabel,-        isSomeRODataLabel,-        isStaticClosureLabel,-        mkCCLabel, mkCCSLabel,--        DynamicLinkerLabelInfo(..),-        mkDynamicLinkerLabel,-        dynamicLinkerLabelInfo,--        mkPicBaseLabel,-        mkDeadStripPreventer,--        mkHpcTicksLabel,--        -- * Predicates-        hasCAF,-        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,-        isMathFun,-        isCFunctionLabel, isGcPtrLabel, labelDynamic,-        isLocalCLabel, mayRedirectTo,--        -- * Conversions-        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,--        pprCLabel,-        isInfoTableLabel,-        isConInfoTableLabel-    ) where--#include "HsVersions.h"--import GhcPrelude--import IdInfo-import BasicTypes-import {-# SOURCE #-} BlockId (BlockId, mkBlockId)-import Packages-import Module-import Name-import Unique-import PrimOp-import CostCentre-import Outputable-import FastString-import DynFlags-import GHC.Platform-import UniqSet-import Util-import PprCore ( {- instances -} )---- -------------------------------------------------------------------------------- The CLabel type--{- |-  'CLabel' is an abstract type that supports the following operations:--  - Pretty printing--  - In a C file, does it need to be declared before use?  (i.e. is it-    guaranteed to be already in scope in the places we need to refer to it?)--  - If it needs to be declared, what type (code or data) should it be-    declared to have?--  - Is it visible outside this object file or not?--  - Is it "dynamic" (see details below)--  - Eq and Ord, so that we can make sets of CLabels (currently only-    used in outputting C as far as I can tell, to avoid generating-    more than one declaration for any given label).--  - Converting an info table label into an entry label.--  CLabel usage is a bit messy in GHC as they are used in a number of different-  contexts:--  - By the C-- AST to identify labels--  - By the unregisterised C code generator ("PprC") for naming functions (hence-    the name 'CLabel')--  - By the native and LLVM code generators to identify labels--  For extra fun, each of these uses a slightly different subset of constructors-  (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and-  LLVM backends).--  In general, we use 'IdLabel' to represent Haskell things early in the-  pipeline. However, later optimization passes will often represent blocks they-  create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the-  label.--}--data CLabel-  = -- | A label related to the definition of a particular Id or Con in a .hs file.-    IdLabel-        Name-        CafInfo-        IdLabelInfo             -- encodes the suffix of the label--  -- | A label from a .cmm file that is not associated with a .hs level Id.-  | CmmLabel-        UnitId               -- what package the label belongs to.-        FastString              -- identifier giving the prefix of the label-        CmmLabelInfo            -- encodes the suffix of the label--  -- | A label with a baked-in \/ algorithmically generated name that definitely-  --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so-  --    If it doesn't have an algorithmically generated name then use a CmmLabel-  --    instead and give it an appropriate UnitId argument.-  | RtsLabel-        RtsLabelInfo--  -- | A label associated with a block. These aren't visible outside of the-  -- compilation unit in which they are defined. These are generally used to-  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,-  -- where we don't have a 'Name' to associate the label to and therefore can't-  -- use 'IdLabel'.-  | LocalBlockLabel-        {-# UNPACK #-} !Unique--  -- | A 'C' (or otherwise foreign) label.-  ---  | ForeignLabel-        FastString              -- name of the imported label.--        (Maybe Int)             -- possible '@n' suffix for stdcall functions-                                -- When generating C, the '@n' suffix is omitted, but when-                                -- generating assembler we must add it to the label.--        ForeignLabelSource      -- what package the foreign label is in.--        FunctionOrData--  -- | Local temporary label used for native (or LLVM) code generation; must not-  -- appear outside of these contexts. Use primarily for debug information-  | AsmTempLabel-        {-# UNPACK #-} !Unique--  -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.-  -- Must not occur outside of the NCG or LLVM code generators.-  | AsmTempDerivedLabel-        CLabel-        FastString              -- suffix--  | StringLitLabel-        {-# UNPACK #-} !Unique--  | CC_Label  CostCentre-  | CCS_Label CostCentreStack---  -- | These labels are generated and used inside the NCG only.-  --    They are special variants of a label used for dynamic linking-  --    see module PositionIndependentCode for details.-  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel--  -- | This label is generated and used inside the NCG only.-  --    It is used as a base for PIC calculations on some platforms.-  --    It takes the form of a local numeric assembler label '1'; and-  --    is pretty-printed as 1b, referring to the previous definition-  --    of 1: in the assembler source file.-  | PicBaseLabel--  -- | A label before an info table to prevent excessive dead-stripping on darwin-  | DeadStripPreventer CLabel---  -- | Per-module table of tick locations-  | HpcTicksLabel Module--  -- | Static reference table-  | SRTLabel-        {-# UNPACK #-} !Unique--  -- | A bitmap (function or case return)-  | LargeBitmapLabel-        {-# UNPACK #-} !Unique--  deriving Eq---- This is laborious, but necessary. We can't derive Ord because--- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the--- implementation. See Note [No Ord for Unique]--- This is non-deterministic but we do not currently support deterministic--- code-generation. See Note [Unique Determinism and code generation]-instance Ord CLabel where-  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =-    compare a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`-    compare c1 c2-  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =-    compare a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`-    compare c1 c2-  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2-  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2-  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =-    compare a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`-    compare c1 c2 `thenCmp`-    compare d1 d2-  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2-  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =-    compare a1 a2 `thenCmp`-    compare b1 b2-  compare (StringLitLabel u1) (StringLitLabel u2) =-    nonDetCmpUnique u1 u2-  compare (CC_Label a1) (CC_Label a2) =-    compare a1 a2-  compare (CCS_Label a1) (CCS_Label a2) =-    compare a1 a2-  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =-    compare a1 a2 `thenCmp`-    compare b1 b2-  compare PicBaseLabel PicBaseLabel = EQ-  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =-    compare a1 a2-  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =-    compare a1 a2-  compare (SRTLabel u1) (SRTLabel u2) =-    nonDetCmpUnique u1 u2-  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =-    nonDetCmpUnique u1 u2-  compare IdLabel{} _ = LT-  compare _ IdLabel{} = GT-  compare CmmLabel{} _ = LT-  compare _ CmmLabel{} = GT-  compare RtsLabel{} _ = LT-  compare _ RtsLabel{} = GT-  compare LocalBlockLabel{} _ = LT-  compare _ LocalBlockLabel{} = GT-  compare ForeignLabel{} _ = LT-  compare _ ForeignLabel{} = GT-  compare AsmTempLabel{} _ = LT-  compare _ AsmTempLabel{} = GT-  compare AsmTempDerivedLabel{} _ = LT-  compare _ AsmTempDerivedLabel{} = GT-  compare StringLitLabel{} _ = LT-  compare _ StringLitLabel{} = GT-  compare CC_Label{} _ = LT-  compare _ CC_Label{} = GT-  compare CCS_Label{} _ = LT-  compare _ CCS_Label{} = GT-  compare DynamicLinkerLabel{} _ = LT-  compare _ DynamicLinkerLabel{} = GT-  compare PicBaseLabel{} _ = LT-  compare _ PicBaseLabel{} = GT-  compare DeadStripPreventer{} _ = LT-  compare _ DeadStripPreventer{} = GT-  compare HpcTicksLabel{} _ = LT-  compare _ HpcTicksLabel{} = GT-  compare SRTLabel{} _ = LT-  compare _ SRTLabel{} = GT---- | Record where a foreign label is stored.-data ForeignLabelSource--   -- | Label is in a named package-   = ForeignLabelInPackage      UnitId--   -- | Label is in some external, system package that doesn't also-   --   contain compiled Haskell code, and is not associated with any .hi files.-   --   We don't have to worry about Haskell code being inlined from-   --   external packages. It is safe to treat the RTS package as "external".-   | ForeignLabelInExternalPackage--   -- | Label is in the package currently being compiled.-   --   This is only used for creating hacky tmp labels during code generation.-   --   Don't use it in any code that might be inlined across a package boundary-   --   (ie, core code) else the information will be wrong relative to the-   --   destination module.-   | ForeignLabelInThisPackage--   deriving (Eq, Ord)----- | For debugging problems with the CLabel representation.---      We can't make a Show instance for CLabel because lots of its components don't have instances.---      The regular Outputable instance only shows the label name, and not its other info.----pprDebugCLabel :: CLabel -> SDoc-pprDebugCLabel lbl- = case lbl of-        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"-                                       <> whenPprDebug (text ":" <> text (show info)))-        CmmLabel pkg _name _info-         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)--        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")--        ForeignLabel _name mSuffix src funOrData-            -> ppr lbl <> (parens $ text "ForeignLabel"-                                <+> ppr mSuffix-                                <+> ppr src-                                <+> ppr funOrData)--        _               -> ppr lbl <> (parens $ text "other CLabel")---data IdLabelInfo-  = Closure             -- ^ Label for closure-  | InfoTable           -- ^ Info tables for closures; always read-only-  | Entry               -- ^ Entry point-  | Slow                -- ^ Slow entry point--  | LocalInfoTable      -- ^ Like InfoTable but not externally visible-  | LocalEntry          -- ^ Like Entry but not externally visible--  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id--  | ConEntry            -- ^ Constructor entry point-  | ConInfoTable        -- ^ Corresponding info table--  | ClosureTable        -- ^ Table of closures for Enum tycons--  | Bytes               -- ^ Content of a string literal. See-                        -- Note [Bytes label].-  | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block-                        -- instead of a closure entry-point.-                        -- See Note [Proc-point local block entry-point].--  deriving (Eq, Ord, Show)---data RtsLabelInfo-  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks-  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}--  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks-  | RtsApEntry           Bool{-updatable-} Int{-arity-}--  | RtsPrimOp PrimOp-  | RtsApFast     FastString    -- ^ _fast versions of generic apply-  | RtsSlowFastTickyCtr String--  deriving (Eq, Ord)-  -- NOTE: Eq on PtrString compares the pointer only, so this isn't-  -- a real equality.----- | What type of Cmm label we're dealing with.---      Determines the suffix appended to the name when a CLabel.CmmLabel---      is pretty printed.-data CmmLabelInfo-  = CmmInfo                     -- ^ misc rts info tables,      suffix _info-  | CmmEntry                    -- ^ misc rts entry points,     suffix _entry-  | CmmRetInfo                  -- ^ misc rts ret info tables,  suffix _info-  | CmmRet                      -- ^ misc rts return points,    suffix _ret-  | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure-  | CmmCode                     -- ^ misc rts code-  | CmmClosure                  -- ^ closures eg CHARLIKE_closure-  | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code-  deriving (Eq, Ord)--data DynamicLinkerLabelInfo-  = CodeStub                    -- MachO: Lfoo$stub, ELF: foo@plt-  | SymbolPtr                   -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo-  | GotSymbolPtr                -- ELF: foo@got-  | GotSymbolOffset             -- ELF: foo@gotoff--  deriving (Eq, Ord)----- -------------------------------------------------------------------------------- Constructing CLabels--- --------------------------------------------------------------------------------- Constructing IdLabels--- These are always local:--mkSRTLabel     :: Unique -> CLabel-mkSRTLabel u = SRTLabel u--mkRednCountsLabel :: Name -> CLabel-mkRednCountsLabel       name    =-  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]---- These have local & (possibly) external variants:-mkLocalClosureLabel      :: Name -> CafInfo -> CLabel-mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel-mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel-mkLocalClosureLabel     name c  = IdLabel name  c Closure-mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable-mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable--mkClosureLabel              :: Name -> CafInfo -> CLabel-mkInfoTableLabel            :: Name -> CafInfo -> CLabel-mkEntryLabel                :: Name -> CafInfo -> CLabel-mkClosureTableLabel         :: Name -> CafInfo -> CLabel-mkConInfoTableLabel         :: Name -> CafInfo -> CLabel-mkBytesLabel                :: Name -> CLabel-mkClosureLabel name         c     = IdLabel name c Closure-mkInfoTableLabel name       c     = IdLabel name c InfoTable-mkEntryLabel name           c     = IdLabel name c Entry-mkClosureTableLabel name    c     = IdLabel name c ClosureTable-mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable-mkBytesLabel name                 = IdLabel name NoCafRefs Bytes--mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel-mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable-                               -- See Note [Proc-point local block entry-point].---- Constructing Cmm Labels-mkDirty_MUT_VAR_Label,-    mkNonmovingWriteBarrierEnabledLabel,-    mkUpdInfoLabel,-    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,-    mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,-    mkMAP_DIRTY_infoLabel,-    mkArrWords_infoLabel,-    mkTopTickyCtrLabel,-    mkCAFBlackHoleInfoTableLabel,-    mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,-    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel-mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction-mkNonmovingWriteBarrierEnabledLabel-                                = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData-mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo-mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo-mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo-mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData-mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo-mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo-mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo-mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData-mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo-mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo-mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo-mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo-mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo-mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry--mkSRTInfoLabel :: Int -> CLabel-mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo- where-   lbl =-     case n of-       1 -> fsLit "stg_SRT_1"-       2 -> fsLit "stg_SRT_2"-       3 -> fsLit "stg_SRT_3"-       4 -> fsLit "stg_SRT_4"-       5 -> fsLit "stg_SRT_5"-       6 -> fsLit "stg_SRT_6"-       7 -> fsLit "stg_SRT_7"-       8 -> fsLit "stg_SRT_8"-       9 -> fsLit "stg_SRT_9"-       10 -> fsLit "stg_SRT_10"-       11 -> fsLit "stg_SRT_11"-       12 -> fsLit "stg_SRT_12"-       13 -> fsLit "stg_SRT_13"-       14 -> fsLit "stg_SRT_14"-       15 -> fsLit "stg_SRT_15"-       16 -> fsLit "stg_SRT_16"-       _ -> panic "mkSRTInfoLabel"--------mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,-  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel-        :: UnitId -> FastString -> CLabel--mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo-mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry-mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo-mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet-mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode-mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData-mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure--mkLocalBlockLabel :: Unique -> CLabel-mkLocalBlockLabel u = LocalBlockLabel u---- Constructing RtsLabels-mkRtsPrimOpLabel :: PrimOp -> CLabel-mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)--mkSelectorInfoLabel  :: Bool -> Int -> CLabel-mkSelectorEntryLabel :: Bool -> Int -> CLabel-mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)-mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)--mkApInfoTableLabel :: Bool -> Int -> CLabel-mkApEntryLabel     :: Bool -> Int -> CLabel-mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)-mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)----- A call to some primitive hand written Cmm code-mkPrimCallLabel :: PrimCall -> CLabel-mkPrimCallLabel (PrimCall str pkg)-        = CmmLabel pkg str CmmPrimCall----- Constructing ForeignLabels---- | Make a foreign label-mkForeignLabel-        :: FastString           -- name-        -> Maybe Int            -- size prefix-        -> ForeignLabelSource   -- what package it's in-        -> FunctionOrData-        -> CLabel--mkForeignLabel = ForeignLabel----- | Update the label size field in a ForeignLabel-addLabelSize :: CLabel -> Int -> CLabel-addLabelSize (ForeignLabel str _ src  fod) sz-    = ForeignLabel str (Just sz) src fod-addLabelSize label _-    = label---- | Whether label is a top-level string literal-isBytesLabel :: CLabel -> Bool-isBytesLabel (IdLabel _ _ Bytes) = True-isBytesLabel _lbl = False---- | Whether label is a non-haskell label (defined in C code)-isForeignLabel :: CLabel -> Bool-isForeignLabel (ForeignLabel _ _ _ _) = True-isForeignLabel _lbl = False---- | Whether label is a static closure label (can come from haskell or cmm)-isStaticClosureLabel :: CLabel -> Bool--- Closure defined in haskell (.hs)-isStaticClosureLabel (IdLabel _ _ Closure) = True--- Closure defined in cmm-isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True-isStaticClosureLabel _lbl = False---- | Whether label is a .rodata label-isSomeRODataLabel :: CLabel -> Bool--- info table defined in haskell (.hs)-isSomeRODataLabel (IdLabel _ _ ClosureTable) = True-isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True-isSomeRODataLabel (IdLabel _ _ InfoTable) = True-isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True-isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True--- info table defined in cmm (.cmm)-isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True-isSomeRODataLabel _lbl = False---- | Whether label is points to some kind of info table-isInfoTableLabel :: CLabel -> Bool-isInfoTableLabel (IdLabel _ _ InfoTable)      = True-isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True-isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True-isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True-isInfoTableLabel _                            = False---- | Whether label is points to constructor info table-isConInfoTableLabel :: CLabel -> Bool-isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True-isConInfoTableLabel _                            = False---- | Get the label size field from a ForeignLabel-foreignLabelStdcallInfo :: CLabel -> Maybe Int-foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info-foreignLabelStdcallInfo _lbl = Nothing----- Constructing Large*Labels-mkBitmapLabel   :: Unique -> CLabel-mkBitmapLabel   uniq            = LargeBitmapLabel uniq---- Constructing Cost Center Labels-mkCCLabel  :: CostCentre      -> CLabel-mkCCSLabel :: CostCentreStack -> CLabel-mkCCLabel           cc          = CC_Label cc-mkCCSLabel          ccs         = CCS_Label ccs--mkRtsApFastLabel :: FastString -> CLabel-mkRtsApFastLabel str = RtsLabel (RtsApFast str)--mkRtsSlowFastTickyCtrLabel :: String -> CLabel-mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)----- Constructing Code Coverage Labels-mkHpcTicksLabel :: Module -> CLabel-mkHpcTicksLabel                = HpcTicksLabel----- Constructing labels used for dynamic linking-mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel-mkDynamicLinkerLabel            = DynamicLinkerLabel--dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)-dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)-dynamicLinkerLabelInfo _        = Nothing--mkPicBaseLabel :: CLabel-mkPicBaseLabel                  = PicBaseLabel----- Constructing miscellaneous other labels-mkDeadStripPreventer :: CLabel -> CLabel-mkDeadStripPreventer lbl        = DeadStripPreventer lbl--mkStringLitLabel :: Unique -> CLabel-mkStringLitLabel                = StringLitLabel--mkAsmTempLabel :: Uniquable a => a -> CLabel-mkAsmTempLabel a                = AsmTempLabel (getUnique a)--mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel-mkAsmTempDerivedLabel = AsmTempDerivedLabel--mkAsmTempEndLabel :: CLabel -> CLabel-mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")---- | Construct a label for a DWARF Debug Information Entity (DIE)--- describing another symbol.-mkAsmTempDieLabel :: CLabel -> CLabel-mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")---- -------------------------------------------------------------------------------- Convert between different kinds of label--toClosureLbl :: CLabel -> CLabel-toClosureLbl (IdLabel n c _) = IdLabel n c Closure-toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure-toClosureLbl l = pprPanic "toClosureLbl" (ppr l)--toSlowEntryLbl :: CLabel -> CLabel-toSlowEntryLbl (IdLabel n _ BlockInfoTable)-  = pprPanic "toSlowEntryLbl" (ppr n)-toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow-toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)--toEntryLbl :: CLabel -> CLabel-toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry-toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry-toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)-                              -- See Note [Proc-point local block entry-point].-toEntryLbl (IdLabel n c _)               = IdLabel n c Entry-toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry-toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet-toEntryLbl l = pprPanic "toEntryLbl" (ppr l)--toInfoLbl :: CLabel -> CLabel-toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable-toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable-toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable-toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo-toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo-toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)--hasHaskellName :: CLabel -> Maybe Name-hasHaskellName (IdLabel n _ _) = Just n-hasHaskellName _               = Nothing---- -------------------------------------------------------------------------------- Does a CLabel's referent itself refer to a CAF?-hasCAF :: CLabel -> Bool-hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]-hasCAF (IdLabel _ MayHaveCafRefs _) = True-hasCAF _                            = False---- Note [ticky for LNE]--- ~~~~~~~~~~~~~~~~~~~~~---- Until 14 Feb 2013, every ticky counter was associated with a--- closure. Thus, ticky labels used IdLabel. It is odd that--- CmmBuildInfoTables.cafTransfers would consider such a ticky label--- reason to add the name to the CAFEnv (and thus eventually the SRT),--- but it was harmless because the ticky was only used if the closure--- was also.------ Since we now have ticky counters for LNEs, it is no longer the case--- that every ticky counter has an actual closure. So I changed the--- generation of ticky counters' CLabels to not result in their--- associated id ending up in the SRT.------ NB IdLabel is still appropriate for ticky ids (as opposed to--- CmmLabel) because the LNE's counter is still related to an .hs Id,--- that Id just isn't for a proper closure.---- -------------------------------------------------------------------------------- Does a CLabel need declaring before use or not?------ See wiki:commentary/compiler/backends/ppr-c#prototypes--needsCDecl :: CLabel -> Bool-  -- False <=> it's pre-declared; don't bother-  -- don't bother declaring Bitmap labels, we always make sure-  -- they are defined before use.-needsCDecl (SRTLabel _)                 = True-needsCDecl (LargeBitmapLabel _)         = False-needsCDecl (IdLabel _ _ _)              = True-needsCDecl (LocalBlockLabel _)          = True--needsCDecl (StringLitLabel _)           = False-needsCDecl (AsmTempLabel _)             = False-needsCDecl (AsmTempDerivedLabel _ _)    = False-needsCDecl (RtsLabel _)                 = False--needsCDecl (CmmLabel pkgId _ _)-        -- Prototypes for labels defined in the runtime system are imported-        --      into HC files via includes/Stg.h.-        | pkgId == rtsUnitId         = False--        -- For other labels we inline one into the HC file directly.-        | otherwise                     = True--needsCDecl l@(ForeignLabel{})           = not (isMathFun l)-needsCDecl (CC_Label _)                 = True-needsCDecl (CCS_Label _)                = True-needsCDecl (HpcTicksLabel _)            = True-needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"-needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"-needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"---- | If a label is a local block label then return just its 'BlockId', otherwise--- 'Nothing'.-maybeLocalBlockLabel :: CLabel -> Maybe BlockId-maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq-maybeLocalBlockLabel _                     = Nothing----- | Check whether a label corresponds to a C function that has---      a prototype in a system header somehere, or is built-in---      to the C compiler. For these labels we avoid generating our---      own C prototypes.-isMathFun :: CLabel -> Bool-isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs-isMathFun _ = False--math_funs :: UniqSet FastString-math_funs = mkUniqSet [-        -- _ISOC99_SOURCE-        (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),-        (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),-        (fsLit "asin"),         (fsLit "asinf"),        (fsLit "asinl"),-        (fsLit "asinh"),        (fsLit "asinhf"),       (fsLit "asinhl"),-        (fsLit "atan"),         (fsLit "atanf"),        (fsLit "atanl"),-        (fsLit "atan2"),        (fsLit "atan2f"),       (fsLit "atan2l"),-        (fsLit "atanh"),        (fsLit "atanhf"),       (fsLit "atanhl"),-        (fsLit "cbrt"),         (fsLit "cbrtf"),        (fsLit "cbrtl"),-        (fsLit "ceil"),         (fsLit "ceilf"),        (fsLit "ceill"),-        (fsLit "copysign"),     (fsLit "copysignf"),    (fsLit "copysignl"),-        (fsLit "cos"),          (fsLit "cosf"),         (fsLit "cosl"),-        (fsLit "cosh"),         (fsLit "coshf"),        (fsLit "coshl"),-        (fsLit "erf"),          (fsLit "erff"),         (fsLit "erfl"),-        (fsLit "erfc"),         (fsLit "erfcf"),        (fsLit "erfcl"),-        (fsLit "exp"),          (fsLit "expf"),         (fsLit "expl"),-        (fsLit "exp2"),         (fsLit "exp2f"),        (fsLit "exp2l"),-        (fsLit "expm1"),        (fsLit "expm1f"),       (fsLit "expm1l"),-        (fsLit "fabs"),         (fsLit "fabsf"),        (fsLit "fabsl"),-        (fsLit "fdim"),         (fsLit "fdimf"),        (fsLit "fdiml"),-        (fsLit "floor"),        (fsLit "floorf"),       (fsLit "floorl"),-        (fsLit "fma"),          (fsLit "fmaf"),         (fsLit "fmal"),-        (fsLit "fmax"),         (fsLit "fmaxf"),        (fsLit "fmaxl"),-        (fsLit "fmin"),         (fsLit "fminf"),        (fsLit "fminl"),-        (fsLit "fmod"),         (fsLit "fmodf"),        (fsLit "fmodl"),-        (fsLit "frexp"),        (fsLit "frexpf"),       (fsLit "frexpl"),-        (fsLit "hypot"),        (fsLit "hypotf"),       (fsLit "hypotl"),-        (fsLit "ilogb"),        (fsLit "ilogbf"),       (fsLit "ilogbl"),-        (fsLit "ldexp"),        (fsLit "ldexpf"),       (fsLit "ldexpl"),-        (fsLit "lgamma"),       (fsLit "lgammaf"),      (fsLit "lgammal"),-        (fsLit "llrint"),       (fsLit "llrintf"),      (fsLit "llrintl"),-        (fsLit "llround"),      (fsLit "llroundf"),     (fsLit "llroundl"),-        (fsLit "log"),          (fsLit "logf"),         (fsLit "logl"),-        (fsLit "log10l"),       (fsLit "log10"),        (fsLit "log10f"),-        (fsLit "log1pl"),       (fsLit "log1p"),        (fsLit "log1pf"),-        (fsLit "log2"),         (fsLit "log2f"),        (fsLit "log2l"),-        (fsLit "logb"),         (fsLit "logbf"),        (fsLit "logbl"),-        (fsLit "lrint"),        (fsLit "lrintf"),       (fsLit "lrintl"),-        (fsLit "lround"),       (fsLit "lroundf"),      (fsLit "lroundl"),-        (fsLit "modf"),         (fsLit "modff"),        (fsLit "modfl"),-        (fsLit "nan"),          (fsLit "nanf"),         (fsLit "nanl"),-        (fsLit "nearbyint"),    (fsLit "nearbyintf"),   (fsLit "nearbyintl"),-        (fsLit "nextafter"),    (fsLit "nextafterf"),   (fsLit "nextafterl"),-        (fsLit "nexttoward"),   (fsLit "nexttowardf"),  (fsLit "nexttowardl"),-        (fsLit "pow"),          (fsLit "powf"),         (fsLit "powl"),-        (fsLit "remainder"),    (fsLit "remainderf"),   (fsLit "remainderl"),-        (fsLit "remquo"),       (fsLit "remquof"),      (fsLit "remquol"),-        (fsLit "rint"),         (fsLit "rintf"),        (fsLit "rintl"),-        (fsLit "round"),        (fsLit "roundf"),       (fsLit "roundl"),-        (fsLit "scalbln"),      (fsLit "scalblnf"),     (fsLit "scalblnl"),-        (fsLit "scalbn"),       (fsLit "scalbnf"),      (fsLit "scalbnl"),-        (fsLit "sin"),          (fsLit "sinf"),         (fsLit "sinl"),-        (fsLit "sinh"),         (fsLit "sinhf"),        (fsLit "sinhl"),-        (fsLit "sqrt"),         (fsLit "sqrtf"),        (fsLit "sqrtl"),-        (fsLit "tan"),          (fsLit "tanf"),         (fsLit "tanl"),-        (fsLit "tanh"),         (fsLit "tanhf"),        (fsLit "tanhl"),-        (fsLit "tgamma"),       (fsLit "tgammaf"),      (fsLit "tgammal"),-        (fsLit "trunc"),        (fsLit "truncf"),       (fsLit "truncl"),-        -- ISO C 99 also defines these function-like macros in math.h:-        -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,-        -- isgreaterequal, isless, islessequal, islessgreater, isunordered--        -- additional symbols from _BSD_SOURCE-        (fsLit "drem"),         (fsLit "dremf"),        (fsLit "dreml"),-        (fsLit "finite"),       (fsLit "finitef"),      (fsLit "finitel"),-        (fsLit "gamma"),        (fsLit "gammaf"),       (fsLit "gammal"),-        (fsLit "isinf"),        (fsLit "isinff"),       (fsLit "isinfl"),-        (fsLit "isnan"),        (fsLit "isnanf"),       (fsLit "isnanl"),-        (fsLit "j0"),           (fsLit "j0f"),          (fsLit "j0l"),-        (fsLit "j1"),           (fsLit "j1f"),          (fsLit "j1l"),-        (fsLit "jn"),           (fsLit "jnf"),          (fsLit "jnl"),-        (fsLit "lgamma_r"),     (fsLit "lgammaf_r"),    (fsLit "lgammal_r"),-        (fsLit "scalb"),        (fsLit "scalbf"),       (fsLit "scalbl"),-        (fsLit "significand"),  (fsLit "significandf"), (fsLit "significandl"),-        (fsLit "y0"),           (fsLit "y0f"),          (fsLit "y0l"),-        (fsLit "y1"),           (fsLit "y1f"),          (fsLit "y1l"),-        (fsLit "yn"),           (fsLit "ynf"),          (fsLit "ynl"),--        -- These functions are described in IEEE Std 754-2008 --        -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661-        (fsLit "nextup"),       (fsLit "nextupf"),      (fsLit "nextupl"),-        (fsLit "nextdown"),     (fsLit "nextdownf"),    (fsLit "nextdownl")-    ]---- -------------------------------------------------------------------------------- | Is a CLabel visible outside this object file or not?---      From the point of view of the code generator, a name is---      externally visible if it has to be declared as exported---      in the .o file's symbol table; that is, made non-static.-externallyVisibleCLabel :: CLabel -> Bool -- not C "static"-externallyVisibleCLabel (StringLitLabel _)      = False-externallyVisibleCLabel (AsmTempLabel _)        = False-externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False-externallyVisibleCLabel (RtsLabel _)            = True-externallyVisibleCLabel (LocalBlockLabel _)     = False-externallyVisibleCLabel (CmmLabel _ _ _)        = True-externallyVisibleCLabel (ForeignLabel{})        = True-externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info-externallyVisibleCLabel (CC_Label _)            = True-externallyVisibleCLabel (CCS_Label _)           = True-externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False-externallyVisibleCLabel (HpcTicksLabel _)       = True-externallyVisibleCLabel (LargeBitmapLabel _)    = False-externallyVisibleCLabel (SRTLabel _)            = False-externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"-externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"--externallyVisibleIdLabel :: IdLabelInfo -> Bool-externallyVisibleIdLabel LocalInfoTable  = False-externallyVisibleIdLabel LocalEntry      = False-externallyVisibleIdLabel BlockInfoTable  = False-externallyVisibleIdLabel _               = True---- -------------------------------------------------------------------------------- Finding the "type" of a CLabel---- For generating correct types in label declarations:--data CLabelType-  = CodeLabel   -- Address of some executable instructions-  | DataLabel   -- Address of data, not a GC ptr-  | GcPtrLabel  -- Address of a (presumably static) GC object--isCFunctionLabel :: CLabel -> Bool-isCFunctionLabel lbl = case labelType lbl of-                        CodeLabel -> True-                        _other    -> False--isGcPtrLabel :: CLabel -> Bool-isGcPtrLabel lbl = case labelType lbl of-                        GcPtrLabel -> True-                        _other     -> False----- | Work out the general type of data at the address of this label---    whether it be code, data, or static GC object.-labelType :: CLabel -> CLabelType-labelType (IdLabel _ _ info)                    = idInfoLabelType info-labelType (CmmLabel _ _ CmmData)                = DataLabel-labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel-labelType (CmmLabel _ _ CmmCode)                = CodeLabel-labelType (CmmLabel _ _ CmmInfo)                = DataLabel-labelType (CmmLabel _ _ CmmEntry)               = CodeLabel-labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel-labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel-labelType (CmmLabel _ _ CmmRet)                 = CodeLabel-labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel-labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel-labelType (RtsLabel (RtsApFast _))              = CodeLabel-labelType (RtsLabel _)                          = DataLabel-labelType (LocalBlockLabel _)                   = CodeLabel-labelType (SRTLabel _)                          = DataLabel-labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel-labelType (ForeignLabel _ _ _ IsData)           = DataLabel-labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"-labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"-labelType (StringLitLabel _)                    = DataLabel-labelType (CC_Label _)                          = DataLabel-labelType (CCS_Label _)                         = DataLabel-labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?-labelType PicBaseLabel                          = DataLabel-labelType (DeadStripPreventer _)                = DataLabel-labelType (HpcTicksLabel _)                     = DataLabel-labelType (LargeBitmapLabel _)                  = DataLabel--idInfoLabelType :: IdLabelInfo -> CLabelType-idInfoLabelType info =-  case info of-    InfoTable     -> DataLabel-    LocalInfoTable -> DataLabel-    BlockInfoTable -> DataLabel-    Closure       -> GcPtrLabel-    ConInfoTable  -> DataLabel-    ClosureTable  -> DataLabel-    RednCounts    -> DataLabel-    Bytes         -> DataLabel-    _             -> CodeLabel----- --------------------------------------------------------------------------------- | Is a 'CLabel' defined in the current module being compiled?------ Sometimes we can optimise references within a compilation unit in ways that--- we couldn't for inter-module references. This provides a conservative--- estimate of whether a 'CLabel' lives in the current module.-isLocalCLabel :: Module -> CLabel -> Bool-isLocalCLabel this_mod lbl =-  case lbl of-    IdLabel name _ _-      | isInternalName name -> True-      | otherwise           -> nameModule name == this_mod-    LocalBlockLabel _       -> True-    _                       -> False---- --------------------------------------------------------------------------------- | Does a 'CLabel' need dynamic linkage?------ When referring to data in code, we need to know whether--- that data resides in a DLL or not. [Win32 only.]--- @labelDynamic@ returns @True@ if the label is located--- in a DLL, be it a data reference or not.-labelDynamic :: DynFlags -> Module -> CLabel -> Bool-labelDynamic dflags this_mod lbl =-  case lbl of-   -- is the RTS in a DLL or not?-   RtsLabel _ ->-     externalDynamicRefs && (this_pkg /= rtsUnitId)--   IdLabel n _ _ ->-     isDllName dflags this_mod n--   -- When compiling in the "dyn" way, each package is to be linked into-   -- its own shared library.-   CmmLabel pkg _ _-    | os == OSMinGW32 ->-       externalDynamicRefs && (this_pkg /= pkg)-    | otherwise ->-       gopt Opt_ExternalDynamicRefs dflags--   LocalBlockLabel _    -> False--   ForeignLabel _ _ source _  ->-       if os == OSMinGW32-       then case source of-            -- Foreign label is in some un-named foreign package (or DLL).-            ForeignLabelInExternalPackage -> True--            -- Foreign label is linked into the same package as the-            -- source file currently being compiled.-            ForeignLabelInThisPackage -> False--            -- Foreign label is in some named package.-            -- When compiling in the "dyn" way, each package is to be-            -- linked into its own DLL.-            ForeignLabelInPackage pkgId ->-                externalDynamicRefs && (this_pkg /= pkgId)--       else -- On Mac OS X and on ELF platforms, false positives are OK,-            -- so we claim that all foreign imports come from dynamic-            -- libraries-            True--   CC_Label cc ->-     externalDynamicRefs && not (ccFromThisModule cc this_mod)--   -- CCS_Label always contains a CostCentre defined in the current module-   CCS_Label _ -> False--   HpcTicksLabel m ->-     externalDynamicRefs && this_mod /= m--   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.-   _                 -> False-  where-    externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags-    os = platformOS (targetPlatform dflags)-    this_pkg = moduleUnitId this_mod----------------------------------------------------------------------------------- Printing out CLabels.--{--Convention:--      <name>_<type>--where <name> is <Module>_<name> for external names and <unique> for-internal names. <type> is one of the following:--         info                   Info table-         srt                    Static reference table-         entry                  Entry code (function, closure)-         slow                   Slow entry code (if any)-         ret                    Direct return address-         vtbl                   Vector table-         <n>_alt                Case alternative (tag n)-         dflt                   Default case alternative-         btm                    Large bitmap vector-         closure                Static closure-         con_entry              Dynamic Constructor entry code-         con_info               Dynamic Constructor info table-         static_entry           Static Constructor entry code-         static_info            Static Constructor info table-         sel_info               Selector info table-         sel_entry              Selector entry code-         cc                     Cost centre-         ccs                    Cost centre stack--Many of these distinctions are only for documentation reasons.  For-example, _ret is only distinguished from _entry to make it easy to-tell whether a code fragment is a return point or a closure/function-entry.--Note [Closure and info labels]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a function 'foo, we have:-   foo_info    : Points to the info table describing foo's closure-                 (and entry code for foo with tables next to code)-   foo_closure : Static (no-free-var) closure only:-                 points to the statically-allocated closure--For a data constructor (such as Just or Nothing), we have:-    Just_con_info: Info table for the data constructor itself-                   the first word of a heap-allocated Just-    Just_info:     Info table for the *worker function*, an-                   ordinary Haskell function of arity 1 that-                   allocates a (Just x) box:-                      Just = \x -> Just x-    Just_closure:  The closure for this worker--    Nothing_closure: a statically allocated closure for Nothing-    Nothing_static_info: info table for Nothing_closure--All these must be exported symbol, EXCEPT Just_info.  We don't need to-export this because in other modules we either have-       * A reference to 'Just'; use Just_closure-       * A saturated call 'Just x'; allocate using Just_con_info-Not exporting these Just_info labels reduces the number of symbols-somewhat.--Note [Bytes label]-~~~~~~~~~~~~~~~~~~-For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which-points to a static data block containing the content of the literal.--Note [Proc-point local block entry-points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A label for a proc-point local block entry-point has no "_entry" suffix. With-`infoTblLbl` we derive an info table label from a proc-point block ID. If-we convert such an info table label into an entry label we must produce-the label without an "_entry" suffix. So an info table label records-the fact that it was derived from a block ID in `IdLabelInfo` as-`BlockInfoTable`.--The info table label and the local block label are both local labels-and are not externally visible.--}--instance Outputable CLabel where-  ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c--pprCLabel :: DynFlags -> CLabel -> SDoc--pprCLabel _ (LocalBlockLabel u)-  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u--pprCLabel dynFlags (AsmTempLabel u)- | not (platformUnregisterised $ targetPlatform dynFlags)-  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u--pprCLabel dynFlags (AsmTempDerivedLabel l suf)- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags-   = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)-     <> case l of AsmTempLabel u    -> pprUniqueAlways u-                  LocalBlockLabel u -> pprUniqueAlways u-                  _other            -> pprCLabel dynFlags l-     <> ftext suf--pprCLabel dynFlags (DynamicLinkerLabel info lbl)- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags-   = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl--pprCLabel dynFlags PicBaseLabel- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags-   = text "1b"--pprCLabel dynFlags (DeadStripPreventer lbl)- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags-   =-   {--      `lbl` can be temp one but we need to ensure that dsp label will stay-      in the final binary so we prepend non-temp prefix ("dsp_") and-      optional `_` (underscore) because this is how you mark non-temp symbols-      on some platforms (Darwin)-   -}-   maybe_underscore dynFlags $ text "dsp_"-   <> pprCLabel dynFlags lbl <> text "_dsp"--pprCLabel dynFlags (StringLitLabel u)- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags-  = pprUniqueAlways u <> ptext (sLit "_str")--pprCLabel dynFlags lbl-   = getPprStyle $ \ sty ->-     if platformMisc_ghcWithNativeCodeGen (platformMisc dynFlags) && asmStyle sty-     then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl-     else pprCLbl lbl--maybe_underscore :: DynFlags -> SDoc -> SDoc-maybe_underscore dynFlags doc =-  if platformMisc_leadingUnderscore $ platformMisc dynFlags-  then pp_cSEP <> doc-  else doc--pprAsmCLbl :: Platform -> CLabel -> SDoc-pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)- | platformOS platform == OSMinGW32-    -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.-    -- (The C compiler does this itself).-    = ftext fs <> char '@' <> int sz-pprAsmCLbl _ lbl-   = pprCLbl lbl--pprCLbl :: CLabel -> SDoc-pprCLbl (StringLitLabel u)-  = pprUniqueAlways u <> text "_str"--pprCLbl (SRTLabel u)-  = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"--pprCLbl (LargeBitmapLabel u)  =-  tempLabelPrefixOrUnderscore-  <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"--- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')--- until that gets resolved we'll just force them to start--- with a letter so the label will be legal assembly code.---pprCLbl (CmmLabel _ str CmmCode)        = ftext str-pprCLbl (CmmLabel _ str CmmData)        = ftext str-pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str--pprCLbl (LocalBlockLabel u)             =-    tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u--pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"--pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))-  = sdocWithDynFlags $ \dflags ->-    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)-    hcat [text "stg_sel_", text (show offset),-          ptext (if upd_reqd-                 then (sLit "_upd_info")-                 else (sLit "_noupd_info"))-        ]--pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))-  = sdocWithDynFlags $ \dflags ->-    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)-    hcat [text "stg_sel_", text (show offset),-                ptext (if upd_reqd-                        then (sLit "_upd_entry")-                        else (sLit "_noupd_entry"))-        ]--pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))-  = sdocWithDynFlags $ \dflags ->-    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)-    hcat [text "stg_ap_", text (show arity),-                ptext (if upd_reqd-                        then (sLit "_upd_info")-                        else (sLit "_noupd_info"))-        ]--pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))-  = sdocWithDynFlags $ \dflags ->-    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)-    hcat [text "stg_ap_", text (show arity),-                ptext (if upd_reqd-                        then (sLit "_upd_entry")-                        else (sLit "_noupd_entry"))-        ]--pprCLbl (CmmLabel _ fs CmmInfo)-  = ftext fs <> text "_info"--pprCLbl (CmmLabel _ fs CmmEntry)-  = ftext fs <> text "_entry"--pprCLbl (CmmLabel _ fs CmmRetInfo)-  = ftext fs <> text "_info"--pprCLbl (CmmLabel _ fs CmmRet)-  = ftext fs <> text "_ret"--pprCLbl (CmmLabel _ fs CmmClosure)-  = ftext fs <> text "_closure"--pprCLbl (RtsLabel (RtsPrimOp primop))-  = text "stg_" <> ppr primop--pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))-  = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")--pprCLbl (ForeignLabel str _ _ _)-  = ftext str--pprCLbl (IdLabel name _cafs flavor) =-  internalNamePrefix name <> ppr name <> ppIdFlavor flavor--pprCLbl (CC_Label cc)           = ppr cc-pprCLbl (CCS_Label ccs)         = ppr ccs--pprCLbl (HpcTicksLabel mod)-  = text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")--pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"-pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"-pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"-pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"-pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"--ppIdFlavor :: IdLabelInfo -> SDoc-ppIdFlavor x = pp_cSEP <> text-               (case x of-                       Closure          -> "closure"-                       InfoTable        -> "info"-                       LocalInfoTable   -> "info"-                       Entry            -> "entry"-                       LocalEntry       -> "entry"-                       Slow             -> "slow"-                       RednCounts       -> "ct"-                       ConEntry         -> "con_entry"-                       ConInfoTable     -> "con_info"-                       ClosureTable     -> "closure_tbl"-                       Bytes            -> "bytes"-                       BlockInfoTable   -> "info"-                      )---pp_cSEP :: SDoc-pp_cSEP = char '_'---instance Outputable ForeignLabelSource where- ppr fs-  = case fs of-        ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId-        ForeignLabelInThisPackage       -> parens $ text "this package"-        ForeignLabelInExternalPackage   -> parens $ text "external package"--internalNamePrefix :: Name -> SDoc-internalNamePrefix name = getPprStyle $ \ sty ->-  if asmStyle sty && isRandomGenerated then-    sdocWithPlatform $ \platform ->-      ptext (asmTempLabelPrefix platform)-  else-    empty-  where-    isRandomGenerated = not $ isExternalName name--tempLabelPrefixOrUnderscore :: SDoc-tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->-  getPprStyle $ \ sty ->-   if asmStyle sty then-      ptext (asmTempLabelPrefix platform)-   else-      char '_'---- -------------------------------------------------------------------------------- Machine-dependent knowledge about labels.--asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels-asmTempLabelPrefix platform = case platformOS platform of-    OSDarwin -> sLit "L"-    OSAIX    -> sLit "__L" -- follow IBM XL C's convention-    _        -> sLit ".L"--pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc-pprDynamicLinkerAsmLabel platform dllInfo lbl =-    case platformOS platform of-      OSDarwin-        | platformArch platform == ArchX86_64 ->-          case dllInfo of-            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"-            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"-            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"-            GotSymbolOffset -> ppr lbl-        | otherwise ->-          case dllInfo of-            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"-            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"-            _         -> panic "pprDynamicLinkerAsmLabel"--      OSAIX ->-          case dllInfo of-            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention-            _         -> panic "pprDynamicLinkerAsmLabel"--      _ | osElfTarget (platformOS platform) -> elfLabel--      OSMinGW32 ->-          case dllInfo of-            SymbolPtr -> text "__imp_" <> ppr lbl-            _         -> panic "pprDynamicLinkerAsmLabel"--      _ -> panic "pprDynamicLinkerAsmLabel"-  where-    elfLabel-      | platformArch platform == ArchPPC-      = case dllInfo of-          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]-                       ppr lbl <> text "+32768@plt"-          SymbolPtr -> text ".LC_" <> ppr lbl-          _         -> panic "pprDynamicLinkerAsmLabel"--      | platformArch platform == ArchX86_64-      = case dllInfo of-          CodeStub        -> ppr lbl <> text "@plt"-          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"-          GotSymbolOffset -> ppr lbl-          SymbolPtr       -> text ".LC_" <> ppr lbl--      | platformArch platform == ArchPPC_64 ELF_V1-        || platformArch platform == ArchPPC_64 ELF_V2-      = case dllInfo of-          GotSymbolPtr    -> text ".LC_"  <> ppr lbl-                                  <> text "@toc"-          GotSymbolOffset -> ppr lbl-          SymbolPtr       -> text ".LC_" <> ppr lbl-          _               -> panic "pprDynamicLinkerAsmLabel"--      | otherwise-      = case dllInfo of-          CodeStub        -> ppr lbl <> text "@plt"-          SymbolPtr       -> text ".LC_" <> ppr lbl-          GotSymbolPtr    -> ppr lbl <> text "@got"-          GotSymbolOffset -> ppr lbl <> text "@gotoff"---- Figure out whether `symbol` may serve as an alias--- to `target` within one compilation unit.------ This is true if any of these holds:--- * `target` is a module-internal haskell name.--- * `target` is an exported name, but comes from the same---   module as `symbol`------ These are sufficient conditions for establishing e.g. a--- GNU assembly alias ('.equiv' directive). Sadly, there is--- no such thing as an alias to an imported symbol (conf.--- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)--- See note [emit-time elimination of static indirections].------ Precondition is that both labels represent the--- same semantic value.--mayRedirectTo :: CLabel -> CLabel -> Bool-mayRedirectTo symbol target- | Just nam <- haskellName- , staticClosureLabel- , isExternalName nam- , Just mod <- nameModule_maybe nam- , Just anam <- hasHaskellName symbol- , Just amod <- nameModule_maybe anam- = amod == mod-- | Just nam <- haskellName- , staticClosureLabel- , isInternalName nam- = True-- | otherwise = False-   where staticClosureLabel = isStaticClosureLabel target-         haskellName = hasHaskellName target---{--Note [emit-time elimination of static indirections]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As described in #15155, certain static values are repesentationally-equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).--             newtype A = A Int-             {-# NOINLINE a #-}-             a = A 42--a1_rYB :: Int-[GblId, Caf=NoCafRefs, Unf=OtherCon []]-a1_rYB = GHC.Types.I# 42#--a [InlPrag=NOINLINE] :: A-[GblId, Unf=OtherCon []]-a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)--Formerly we created static indirections for these (IND_STATIC), which-consist of a statically allocated forwarding closure that contains-the (possibly tagged) indirectee. (See CMM/assembly below.)-This approach is suboptimal for two reasons:-  (a) they occupy extra space,-  (b) they need to be entered in order to obtain the indirectee,-      thus they cannot be tagged.--Fortunately there is a common case where static indirections can be-eliminated while emitting assembly (native or LLVM), viz. when the-indirectee is in the same module (object file) as the symbol that-points to it. In this case an assembly-level identification can-be created ('.equiv' directive), and as such the same object will-be assigned two names in the symbol table. Any of the identified-symbols can be referenced by a tagged pointer.--Currently the 'mayRedirectTo' predicate will-give a clue whether a label can be equated with another, already-emitted, label (which can in turn be an alias). The general mechanics-is that we identify data (IND_STATIC closures) that are amenable-to aliasing while pretty-printing of assembly output, and emit the-'.equiv' directive instead of static data in such a case.--Here is a sketch how the output is massaged:--                     Consider-newtype A = A Int-{-# NOINLINE a #-}-a = A 42                                -- I# 42# is the indirectee-                                        -- 'a' is exported--                 results in STG--a1_rXq :: GHC.Types.Int-[GblId, Caf=NoCafRefs, Unf=OtherCon []] =-    CCS_DONT_CARE GHC.Types.I#! [42#];--T15155.a [InlPrag=NOINLINE] :: T15155.A-[GblId, Unf=OtherCon []] =-    CAF_ccs  \ u  []  a1_rXq;--                 and CMM--[section ""data" . a1_rXq_closure" {-     a1_rXq_closure:-         const GHC.Types.I#_con_info;-         const 42;- }]--[section ""data" . T15155.a_closure" {-     T15155.a_closure:-         const stg_IND_STATIC_info;-         const a1_rXq_closure+1;-         const 0;-         const 0;- }]--The emitted assembly is--#### INDIRECTEE-a1_rXq_closure:                         -- module local haskell value-        .quad   GHC.Types.I#_con_info   -- an Int-        .quad   42--#### BEFORE-.globl T15155.a_closure                 -- exported newtype wrapped value-T15155.a_closure:-        .quad   stg_IND_STATIC_info     -- the closure info-        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)-        .quad   0-        .quad   0--#### AFTER-.globl T15155.a_closure                 -- exported newtype wrapped value-.equiv a1_rXq_closure,T15155.a_closure  -- both are shared--The transformation is performed because-     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1-returns True.--}
− compiler/cmm/Cmm.hs 
@@ -1,231 +0,0 @@--- Cmm representations using Hoopl's Graph CmmNode e x.-{-# LANGUAGE GADTs #-}--module Cmm (-     -- * Cmm top-level datatypes-     CmmProgram, CmmGroup, GenCmmGroup,-     CmmDecl, GenCmmDecl(..),-     CmmGraph, GenCmmGraph(..),-     CmmBlock,-     RawCmmDecl, RawCmmGroup,-     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),-     isSecConstant,--     -- ** Blocks containing lists-     GenBasicBlock(..), blockId,-     ListGraph(..), pprBBlock,--     -- * Info Tables-     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,-     ClosureTypeInfo(..),-     ProfilingInfo(..), ConstrDescription,--     -- * Statements, expressions and types-     module CmmNode,-     module CmmExpr,-  ) where--import GhcPrelude--import Id-import CostCentre-import CLabel-import BlockId-import CmmNode-import SMRep-import CmmExpr-import Hoopl.Block-import Hoopl.Collections-import Hoopl.Graph-import Hoopl.Label-import Outputable-import Data.ByteString (ByteString)----------------------------------------------------------------------------------  Cmm, GenCmm---------------------------------------------------------------------------------- A CmmProgram is a list of CmmGroups--- A CmmGroup is a list of top-level declarations---- When object-splitting is on, each group is compiled into a separate--- .o file. So typically we put closely related stuff in a CmmGroup.--- Section-splitting follows suit and makes one .text subsection for each--- CmmGroup.--type CmmProgram = [CmmGroup]--type GenCmmGroup d h g = [GenCmmDecl d h g]-type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph-type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph----------------------------------------------------------------------------------  CmmDecl, GenCmmDecl---------------------------------------------------------------------------------- GenCmmDecl is abstracted over---   d, the type of static data elements in CmmData---   h, the static info preceding the code of a CmmProc---   g, the control-flow graph of a CmmProc------ We expect there to be two main instances of this type:---   (a) C--, i.e. populated with various C-- constructs---   (b) Native code, populated with data/instructions---- | A top-level chunk, abstracted over the type of the contents of--- the basic blocks (Cmm or instructions are the likely instantiations).-data GenCmmDecl d h g-  = CmmProc     -- A procedure-     h                 -- Extra header such as the info table-     CLabel            -- Entry label-     [GlobalReg]       -- Registers live on entry. Note that the set of live-                       -- registers will be correct in generated C-- code, but-                       -- not in hand-written C-- code. However,-                       -- splitAtProcPoints calculates correct liveness-                       -- information for CmmProcs.-     g                 -- Control-flow graph for the procedure's code--  | CmmData     -- Static data-        Section-        d--type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph--type RawCmmDecl-   = GenCmmDecl-        CmmStatics-        (LabelMap CmmStatics)-        CmmGraph----------------------------------------------------------------------------------     Graphs--------------------------------------------------------------------------------type CmmGraph = GenCmmGraph CmmNode-data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }-type CmmBlock = Block CmmNode C C----------------------------------------------------------------------------------     Info Tables---------------------------------------------------------------------------------- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains--- the extra info (beyond the executable code) that belongs to that CmmDecl.-data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable-                            , stack_info :: CmmStackInfo }--topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable-topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)-topInfoTable _                     = Nothing--data CmmStackInfo-   = StackInfo {-       arg_space :: ByteOff,-               -- number of bytes of arguments on the stack on entry to the-               -- the proc.  This is filled in by GHC.StgToCmm.codeGen, and-               -- used by the stack allocator later.-       updfr_space :: Maybe ByteOff,-               -- XXX: this never contains anything useful, but it should.-               -- See comment in CmmLayoutStack.-       do_layout :: Bool-               -- Do automatic stack layout for this proc.  This is-               -- True for all code generated by the code generator,-               -- but is occasionally False for hand-written Cmm where-               -- we want to do the stack manipulation manually.-  }---- | Info table as a haskell data type-data CmmInfoTable-  = CmmInfoTable {-      cit_lbl  :: CLabel, -- Info table label-      cit_rep  :: SMRep,-      cit_prof :: ProfilingInfo,-      cit_srt  :: Maybe CLabel,   -- empty, or a closure address-      cit_clo  :: Maybe (Id, CostCentreStack)-        -- Just (id,ccs) <=> build a static closure later-        -- Nothing <=> don't build a static closure-        ---        -- Static closures for FUNs and THUNKs are *not* generated by-        -- the code generator, because we might want to add SRT-        -- entries to them later (for FUNs at least; THUNKs are-        -- treated the same for consistency). See Note [SRTs] in-        -- CmmBuildInfoTables, in particular the [FUN] optimisation.-        ---        -- This is strictly speaking not a part of the info table that-        -- will be finally generated, but it's the only convenient-        -- place to convey this information from the code generator to-        -- where we build the static closures in-        -- CmmBuildInfoTables.doSRTs.-    }--data ProfilingInfo-  = NoProfilingInfo-  | ProfilingInfo ByteString ByteString -- closure_type, closure_desc----------------------------------------------------------------------------------              Static Data--------------------------------------------------------------------------------data SectionType-  = Text-  | Data-  | ReadOnlyData-  | RelocatableReadOnlyData-  | UninitialisedData-  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned-  | CString-  | OtherSection String-  deriving (Show)---- | Should a data in this section be considered constant-isSecConstant :: Section -> Bool-isSecConstant (Section t _) = case t of-    Text                    -> True-    ReadOnlyData            -> True-    RelocatableReadOnlyData -> True-    ReadOnlyData16          -> True-    CString                 -> True-    Data                    -> False-    UninitialisedData       -> False-    (OtherSection _)        -> False--data Section = Section SectionType CLabel--data CmmStatic-  = CmmStaticLit CmmLit-        -- a literal value, size given by cmmLitRep of the literal.-  | CmmUninitialised Int-        -- uninitialised data, N bytes long-  | CmmString ByteString-        -- string of 8-bit values only, not zero terminated.--data CmmStatics-   = Statics-       CLabel      -- Label of statics-       [CmmStatic] -- The static data itself---- -------------------------------------------------------------------------------- Basic blocks consisting of lists---- These are used by the LLVM and NCG backends, when populating Cmm--- with lists of instructions.--data GenBasicBlock i = BasicBlock BlockId [i]---- | The branch block id is that of the first block in--- the branch, which is that branch's entry point-blockId :: GenBasicBlock i -> BlockId-blockId (BasicBlock blk_id _ ) = blk_id--newtype ListGraph i = ListGraph [GenBasicBlock i]--instance Outputable instr => Outputable (ListGraph instr) where-    ppr (ListGraph blocks) = vcat (map ppr blocks)--instance Outputable instr => Outputable (GenBasicBlock instr) where-    ppr = pprBBlock--pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc-pprBBlock (BasicBlock ident stmts) =-    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))-
− compiler/cmm/CmmBuildInfoTables.hs 
@@ -1,892 +0,0 @@-{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,-    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}--module CmmBuildInfoTables-  ( CAFSet, CAFEnv, cafAnal-  , doSRTs, ModuleSRTInfo, emptySRT-  ) where--import GhcPrelude hiding (succ)--import Id-import BlockId-import Hoopl.Block-import Hoopl.Graph-import Hoopl.Label-import Hoopl.Collections-import Hoopl.Dataflow-import Module-import GHC.Platform-import Digraph-import CLabel-import Cmm-import CmmUtils-import DynFlags-import Maybes-import Outputable-import SMRep-import UniqSupply-import CostCentre-import GHC.StgToCmm.Heap--import Control.Monad-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Tuple-import Control.Monad.Trans.State-import Control.Monad.Trans.Class---{- Note [SRTs]--SRTs are the mechanism by which the garbage collector can determine-the live CAFs in the program.--Representation-^^^^^^^^^^^^^^--+------+-| info |-|      |     +-----+---+---+---+-|   -------->|SRT_2| | | | | 0 |-|------|     +-----+-|-+-|-+---+-|      |             |   |-| code |             |   |-|      |             v   v--An SRT is simply an object in the program's data segment. It has the-same representation as a static constructor.  There are 16-pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,-representing SRT objects with 1-16 pointers, respectively.--The entries of an SRT object point to static closures, which are either-- FUN_STATIC, THUNK_STATIC or CONSTR-- Another SRT (actually just a CONSTR)--The final field of the SRT is the static link field, used by the-garbage collector to chain together static closures that it visits and-to determine whether a static closure has been visited or not. (see-Note [STATIC_LINK fields])--By traversing the transitive closure of an SRT, the GC will reach all-of the CAFs that are reachable from the code associated with this SRT.--If we need to create an SRT with more than 16 entries, we build a-chain of SRT objects with all but the last having 16 entries.--+-----+---+- -+---+---+-|SRT16| | |   | | | 0 |-+-----+-|-+- -+-|-+---+-        |       |-        v       v-              +----+---+---+---+-              |SRT2| | | | | 0 |-              +----+-|-+-|-+---+-                     |   |-                     |   |-                     v   v--Referring to an SRT from the info table-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^--The following things have SRTs:--- Static functions (FUN)-- Static thunks (THUNK), ie. CAFs-- Continuations (RET_SMALL, etc.)--In each case, the info table points to the SRT.--- info->srt is zero if there's no SRT, otherwise:-- info->srt == 1 and info->f.srt_offset points to the SRT--e.g. for a FUN with an SRT:--StgFunInfoTable       +------+-  info->f.srt_offset  |  ------------> offset to SRT object-StgStdInfoTable       +------+-  info->layout.ptrs   | ...  |-  info->layout.nptrs  | ...  |-  info->srt           |  1   |-  info->type          | ...  |-                      |------|--On x86_64, we optimise the info table representation further.  The-offset to the SRT can be stored in 32 bits (all code lives within a-2GB region in x86_64's small memory model), so we can save a word in-the info table by storing the srt_offset in the srt field, which is-half a word.--On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):--- info->srt is zero if there's no SRT, otherwise:-- info->srt is an offset from the info pointer to the SRT object--StgStdInfoTable       +------+-  info->layout.ptrs   |      |-  info->layout.nptrs  |      |-  info->srt           |  ------------> offset to SRT object-                      |------|---EXAMPLE-^^^^^^^--f = \x. ... g ...-  where-    g = \y. ... h ... c1 ...-    h = \z. ... c2 ...--c1 & c2 are CAFs--g and h are local functions, but they have no static closures.  When-we generate code for f, we start with a CmmGroup of four CmmDecls:--   [ f_closure, f_entry, g_entry, h_entry ]--we process each CmmDecl separately in cpsTop, giving us a list of-CmmDecls. e.g. for f_entry, we might end up with--   [ f_entry, f1_ret, f2_proc ]--where f1_ret is a return point, and f2_proc is a proc-point.  We have-a CAFSet for each of these CmmDecls, let's suppose they are--   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]-   [ g_entry{h_info, c1_closure} ]-   [ h_entry{c2_closure} ]--Next, we make an SRT for each of these functions:--  f_srt : [g_info]-  g_srt : [h_info, c1_closure]-  h_srt : [c2_closure]--Now, for g_info and h_info, we want to refer to the SRTs for g and h-respectively, which we'll label g_srt and h_srt:--  f_srt : [g_srt]-  g_srt : [h_srt, c1_closure]-  h_srt : [c2_closure]--Now, when an SRT has a single entry, we don't actually generate an SRT-closure for it, instead we just replace references to it with its-single element.  So, since h_srt == c2_closure, we have--  f_srt : [g_srt]-  g_srt : [c2_closure, c1_closure]-  h_srt : [c2_closure]--and the only SRT closure we generate is--  g_srt = SRT_2 [c2_closure, c1_closure]---Optimisations-^^^^^^^^^^^^^--To reduce the code size overhead and the cost of traversing SRTs in-the GC, we want to simplify SRTs where possible. We therefore apply-the following optimisations.  Each has a [keyword]; search for the-keyword in the code below to see where the optimisation is-implemented.--1. [Inline] we never create an SRT with a single entry, instead we-   point to the single entry directly from the info table.--   i.e. instead of--    +------+-    | info |-    |      |     +-----+---+---+-    |   -------->|SRT_1| | | 0 |-    |------|     +-----+-|-+---+-    |      |             |-    | code |             |-    |      |             v-                         C--   we can point directly to the closure:--    +------+-    | info |-    |      |-    |   -------->C-    |------|-    |      |-    | code |-    |      |---   Furthermore, the SRT for any code that refers to this info table-   can point directly to C.--   The exception to this is when we're doing dynamic linking. In that-   case, if the closure is not locally defined then we can't point to-   it directly from the info table, because this is the text section-   which cannot contain runtime relocations. In this case we skip this-   optimisation and generate the singleton SRT, becase SRTs are in the-   data section and *can* have relocatable references.--2. [FUN] A static function closure can also be an SRT, we simply put-   the SRT entries as fields in the static closure.  This makes a lot-   of sense: the static references are just like the free variables of-   the FUN closure.--   i.e. instead of--   f_closure:-   +-----+---+-   |  |  | 0 |-   +- |--+---+-      |            +------+-      |            | info |     f_srt:-      |            |      |     +-----+---+---+---+-      |            |   -------->|SRT_2| | | | + 0 |-      `----------->|------|     +-----+-|-+-|-+---+-                   |      |             |   |-                   | code |             |   |-                   |      |             v   v---   We can generate:--   f_closure:-   +-----+---+---+---+-   |  |  | | | | | 0 |-   +- |--+-|-+-|-+---+-      |    |   |   +------+-      |    v   v   | info |-      |            |      |-      |            |   0  |-      `----------->|------|-                   |      |-                   | code |-                   |      |---   (note: we can't do this for THUNKs, because the thunk gets-   overwritten when it is entered, so we wouldn't be able to share-   this SRT with other info tables that want to refer to it (see-   [Common] below). FUNs are immutable so don't have this problem.)--3. [Common] Identical SRTs can be commoned up.--4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also-   refers to C (perhaps transitively), then we can omit the reference-   to C from A.---Note that there are many other optimisations that we could do, but-aren't implemented. In general, we could omit any reference from an-SRT if everything reachable from it is also reachable from the other-fields in the SRT. Our [Filter] optimisation is a special case of-this.--Another opportunity we don't exploit is this:--A = {X,Y,Z}-B = {Y,Z}-C = {X,B}--Here we could use C = {A} and therefore [Inline] C = A.--}---- ----------------------------------------------------------------------{- Note [Invalid optimisation: shortcutting]--You might think that if we have something like--A's SRT = {B}-B's SRT = {X}--that we could replace the reference to B in A's SRT with X.--A's SRT = {X}-B's SRT = {X}--and thereby perhaps save a little work at runtime, because we don't-have to visit B.--But this is NOT valid.--Consider these cases:--0. B can't be a constructor, because constructors don't have SRTs--1. B is a CAF. This is the easy one. Obviously we want A's SRT to-   point to B, so that it keeps B alive.--2. B is a function.  This is the tricky one. The reason we can't-shortcut in this case is that we aren't allowed to resurrect static-objects.--== How does this cause a problem? ==--The particular case that cropped up when we tried this was #15544.-- A is a thunk-- B is a static function-- X is a CAF-- suppose we GC when A is alive, and B is not otherwise reachable.-- B is "collected", meaning that it doesn't make it onto the static-  objects list during this GC, but nothing bad happens yet.-- Next, suppose we enter A, and then call B. (remember that A refers to B)-  At the entry point to B, we GC. This puts B on the stack, as part of the-  RET_FUN stack frame that gets pushed when we GC at a function entry point.-- This GC will now reach B-- But because B was previous "collected", it breaks the assumption-  that static objects are never resurrected. See Note [STATIC_LINK-  fields] in rts/sm/Storage.h for why this is bad.-- In practice, the GC thinks that B has already been visited, and so-  doesn't visit X, and catastrophe ensues.--== Isn't this caused by the RET_FUN business? ==--Maybe, but could you prove that RET_FUN is the only way that-resurrection can occur?--So, no shortcutting.--}---- ------------------------------------------------------------------------ Label types---- Labels that come from cafAnal can be:---   - _closure labels for static functions or CAFs---   - _info labels for dynamic functions, thunks, or continuations---   - _entry labels for functions or thunks------ Meanwhile the labels on top-level blocks are _entry labels.------ To put everything in the same namespace we convert all labels to--- closure labels using toClosureLbl.  Note that some of these--- labels will not actually exist; that's ok because we're going to--- map them to SRTEntry later, which ranges over labels that do exist.----newtype CAFLabel = CAFLabel CLabel-  deriving (Eq,Ord,Outputable)--type CAFSet = Set CAFLabel-type CAFEnv = LabelMap CAFSet--mkCAFLabel :: CLabel -> CAFLabel-mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)---- This is a label that we can put in an SRT.  It *must* be a closure label,--- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.-newtype SRTEntry = SRTEntry CLabel-  deriving (Eq, Ord, Outputable)---- ------------------------------------------------------------------------ CAF analysis---- |--- For each code block:---   - collect the references reachable from this code block to FUN,---     THUNK or RET labels for which hasCAF == True------ This gives us a `CAFEnv`: a mapping from code block to sets of labels----cafAnal-  :: LabelSet   -- The blocks representing continuations, ie. those-                -- that will get RET info tables.  These labels will-                -- get their own SRTs, so we don't aggregate CAFs from-                -- references to these labels, we just use the label.-  -> CLabel     -- The top label of the proc-  -> CmmGraph-  -> CAFEnv-cafAnal contLbls topLbl cmmGraph =-  analyzeCmmBwd cafLattice-    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty---cafLattice :: DataflowLattice CAFSet-cafLattice = DataflowLattice Set.empty add-  where-    add (OldFact old) (NewFact new) =-        let !new' = old `Set.union` new-        in changedIf (Set.size new' > Set.size old) new'---cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet-cafTransfers contLbls entry topLbl-  (BlockCC eNode middle xNode) fBase =-    let joined = cafsInNode xNode $! live'-        !result = foldNodesBwdOO cafsInNode middle joined--        facts = mapMaybe successorFact (successors xNode)-        live' = joinFacts cafLattice facts--        successorFact s-          -- If this is a loop back to the entry, we can refer to the-          -- entry label.-          | s == entry = Just (add topLbl Set.empty)-          -- If this is a continuation, we want to refer to the-          -- SRT for the continuation's info table-          | s `setMember` contLbls-          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))-          -- Otherwise, takes the CAF references from the destination-          | otherwise-          = lookupFact s fBase--        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet-        cafsInNode node set = foldExpDeep addCaf node set--        addCaf expr !set =-          case expr of-              CmmLit (CmmLabel c) -> add c set-              CmmLit (CmmLabelOff c _) -> add c set-              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set-              _ -> set-        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s-                | otherwise = s--    in mapSingleton (entryLabel eNode) result----- -------------------------------------------------------------------------------- ModuleSRTInfo--data ModuleSRTInfo = ModuleSRTInfo-  { thisModule :: Module-    -- ^ Current module being compiled. Required for calling labelDynamic.-  , dedupSRTs :: Map (Set SRTEntry) SRTEntry-    -- ^ previous SRTs we've emitted, so we can de-duplicate.-    -- Used to implement the [Common] optimisation.-  , flatSRTs :: Map SRTEntry (Set SRTEntry)-    -- ^ The reverse mapping, so that we can remove redundant-    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b-    -- points to [c,d], we can omit c and emit [a,b].-    -- Used to implement the [Filter] optimisation.-  }-instance Outputable ModuleSRTInfo where-  ppr ModuleSRTInfo{..} =-    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs--emptySRT :: Module -> ModuleSRTInfo-emptySRT mod =-  ModuleSRTInfo-    { thisModule = mod-    , dedupSRTs = Map.empty-    , flatSRTs = Map.empty }---- -------------------------------------------------------------------------------- Constructing SRTs--{- Implementation notes--- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable--- The entry in info_tbls corresponding to g_entry is the closure info-  table, the rest are continuations.--- Each entry in info_tbls possibly needs an SRT.  We need to make a-  label for each of these.--- We get the CAFSet for each entry from the CAFEnv---}---- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,---   where the label is---   - the info label for a continuation or dynamic closure---   - the closure label for a top-level function (not a CAF)-getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]-getLabelledBlocks (CmmData _ _) = []-getLabelledBlocks (CmmProc top_info _ _ _) =-  [ (blockId, mkCAFLabel (cit_lbl info))-  | (blockId, info) <- mapToList (info_tbls top_info)-  , let rep = cit_rep info-  , not (isStaticRep rep) || not (isThunkRep rep)-  ]----- | Put the labelled blocks that we will be annotating with SRTs into--- dependency order.  This is so that we can process them one at a--- time, resolving references to earlier blocks to point to their--- SRTs. CAFs themselves are not included here; see getCAFs below.-depAnalSRTs-  :: CAFEnv-  -> [CmmDecl]-  -> [SCC (Label, CAFLabel, Set CAFLabel)]-depAnalSRTs cafEnv decls =-  srtTrace "depAnalSRTs" (ppr graph) graph- where-  labelledBlocks = concatMap getLabelledBlocks decls-  labelToBlock = Map.fromList (map swap labelledBlocks)-  graph = stronglyConnCompFromEdgedVerticesOrd-             [ let cafs' = Set.delete lbl cafs in-               DigraphNode (l,lbl,cafs') l-                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))-             | (l, lbl) <- labelledBlocks-             , Just cafs <- [mapLookup l cafEnv] ]----- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.--- These are treated differently from other labelled blocks:---  - we never shortcut a reference to a CAF to the contents of its---    SRT, since the point of SRTs is to keep CAFs alive.---  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.---    instead we generate their SRTs after everything else.-getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]-getCAFs cafEnv decls =-  [ (g_entry g, mkCAFLabel topLbl, cafs)-  | CmmProc top_info topLbl _ g <- decls-  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]-  , let rep = cit_rep info-  , isStaticRep rep && isThunkRep rep-  , Just cafs <- [mapLookup (g_entry g) cafEnv]-  ]----- | Get the list of blocks that correspond to the entry points for--- FUN_STATIC closures.  These are the blocks for which if we have an--- SRT we can merge it with the static closure. [FUN]-getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]-getStaticFuns decls =-  [ (g_entry g, lbl)-  | CmmProc top_info _ _ g <- decls-  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]-  , Just (id, _) <- [cit_clo info]-  , let rep = cit_rep info-  , isStaticRep rep && isFunRep rep-  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)-  ]----- | Maps labels from 'cafAnal' to the final CLabel that will appear--- in the SRT.---   - closures with singleton SRTs resolve to their single entry---   - closures with larger SRTs map to the label for that SRT---   - CAFs must not map to anything!---   - if a labels maps to Nothing, we found that this label's SRT---     is empty, so we don't need to refer to it from other SRTs.-type SRTMap = Map CAFLabel (Maybe SRTEntry)---- | resolve a CAFLabel to its SRTEntry using the SRTMap-resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry-resolveCAF srtMap lbl@(CAFLabel l) =-  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap----- | Attach SRTs to all info tables in the CmmDecls, and add SRT--- declarations to the ModuleSRTInfo.----doSRTs-  :: DynFlags-  -> ModuleSRTInfo-  -> [(CAFEnv, [CmmDecl])]-  -> IO (ModuleSRTInfo, [CmmDecl])--doSRTs dflags moduleSRTInfo tops = do-  us <- mkSplitUniqSupply 'u'--  -- Ignore the original grouping of decls, and combine all the-  -- CAFEnvs into a single CAFEnv.-  let (cafEnvs, declss) = unzip tops-      cafEnv = mapUnions cafEnvs-      decls = concat declss-      staticFuns = mapFromList (getStaticFuns decls)--  -- Put the decls in dependency order. Why? So that we can implement-  -- [Inline] and [Filter].  If we need to refer to an SRT that has-  -- a single entry, we use the entry itself, which means that we-  -- don't need to generate the singleton SRT in the first place.  But-  -- to do this we need to process blocks before things that depend on-  -- them.-  let-    sccs = depAnalSRTs cafEnv decls-    cafsWithSRTs = getCAFs cafEnv decls--  -- On each strongly-connected group of decls, construct the SRT-  -- closures and the SRT fields for info tables.-  let result ::-        [ ( [CmmDecl]              -- generated SRTs-          , [(Label, CLabel)]      -- SRT fields for info tables-          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-          ) ]-      ((result, _srtMap), moduleSRTInfo') =-        initUs_ us $-        flip runStateT moduleSRTInfo $-        flip runStateT Map.empty $ do-          nonCAFs <- mapM (doSCC dflags staticFuns) sccs-          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->-            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs-          return (nonCAFs ++ cAFs)--      (declss, pairs, funSRTs) = unzip3 result--  -- Next, update the info tables with the SRTs-  let-    srtFieldMap = mapFromList (concat pairs)-    funSRTMap = mapFromList (concat funSRTs)-    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls--  return (moduleSRTInfo', concat declss ++ decls')----- | Build the SRT for a strongly-connected component of blocks-doSCC-  :: DynFlags-  -> LabelMap CLabel           -- which blocks are static function entry points-  -> SCC (Label, CAFLabel, Set CAFLabel)-  -> StateT SRTMap-        (StateT ModuleSRTInfo UniqSM)-        ( [CmmDecl]              -- generated SRTs-        , [(Label, CLabel)]      -- SRT fields for info tables-        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-        )--doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =-  oneSRT dflags staticFuns [l] [cafLbl] False cafs--doSCC dflags staticFuns (CyclicSCC nodes) = do-  -- build a single SRT for the whole cycle, see Note [recursive SRTs]-  let (blockids, lbls, cafsets) = unzip3 nodes-      cafs = Set.unions cafsets-  oneSRT dflags staticFuns blockids lbls False cafs---{- Note [recursive SRTs]--If the dependency analyser has found us a recursive group of-declarations, then we build a single SRT for the whole group, on the-grounds that everything in the group is reachable from everything-else, so we lose nothing by having a single SRT.--However, there are a couple of wrinkles to be aware of.--* The Set CAFLabel for this SRT will contain labels in the group-itself. The SRTMap will therefore not contain entries for these labels-yet, so we can't turn them into SRTEntries using resolveCAF. BUT we-can just remove recursive references from the Set CAFLabel before-generating the SRT - the SRT will still contain all the CAFLabels that-we need to refer to from this group's SRT.--* That is, EXCEPT for static function closures. For the same reason-described in Note [Invalid optimisation: shortcutting], we cannot omit-references to static function closures.-  - But, since we will merge the SRT with one of the static function-    closures (see [FUN]), we can omit references to *that* static-    function closure from the SRT.--}---- | Build an SRT for a set of blocks-oneSRT-  :: DynFlags-  -> LabelMap CLabel            -- which blocks are static function entry points-  -> [Label]                    -- blocks in this set-  -> [CAFLabel]                 -- labels for those blocks-  -> Bool                       -- True <=> this SRT is for a CAF-  -> Set CAFLabel               -- SRT for this set-  -> StateT SRTMap-       (StateT ModuleSRTInfo UniqSM)-       ( [CmmDecl]                    -- SRT objects we built-       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls-       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions-       )--oneSRT dflags staticFuns blockids lbls isCAF cafs = do-  srtMap <- get-  topSRT <- lift get-  let-    -- Can we merge this SRT with a FUN_STATIC closure?-    (maybeFunClosure, otherFunLabels) =-      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of-        [] -> (Nothing, [])-        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)--    -- Remove recursive references from the SRT, except for (all but-    -- one of the) static functions. See Note [recursive SRTs].-    nonRec = cafs `Set.difference`-      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)--    -- First resolve all the CAFLabels to SRTEntries-    -- Implements the [Inline] optimisation.-    resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)--    -- The set of all SRTEntries in SRTs that we refer to from here.-    allBelow =-      Set.unions [ lbls | caf <- resolved-                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]--    -- Remove SRTEntries that are also in an SRT that we refer to.-    -- Implements the [Filter] optimisation.-    filtered = Set.difference (Set.fromList resolved) allBelow--  srtTrace "oneSRT:"-     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()--  let-    isStaticFun = isJust maybeFunClosure--    -- For a label without a closure (e.g. a continuation), we must-    -- update the SRTMap for the label to point to a closure. It's-    -- important that we don't do this for static functions or CAFs,-    -- see Note [Invalid optimisation: shortcutting].-    updateSRTMap srtEntry =-      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do-        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]-        put (Map.union newSRTMap srtMap)--    this_mod = thisModule topSRT--  case Set.toList filtered of-    [] -> do-      srtTrace "oneSRT: empty" (ppr lbls) $ return ()-      updateSRTMap Nothing-      return ([], [], [])--    -- [Inline] - when we have only one entry there is no need to-    -- build an SRT object at all, instead we put the singleton SRT-    -- entry in the info table.-    [one@(SRTEntry lbl)]-      | -- Info tables refer to SRTs by offset (as noted in the section-        -- "Referring to an SRT from the info table" of Note [SRTs]). However,-        -- when dynamic linking is used we cannot guarantee that the offset-        -- between the SRT and the info table will fit in the offset field.-        -- Consequently we build a singleton SRT in in this case.-        not (labelDynamic dflags this_mod lbl)--        -- MachO relocations can't express offsets between compilation units at-        -- all, so we are always forced to build a singleton SRT in this case.-          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)-             || isLocalCLabel this_mod lbl) -> do--        -- If we have a static function closure, then it becomes the-        -- SRT object, and everything else points to it. (the only way-        -- we could have multiple labels here is if this is a-        -- recursive group, see Note [recursive SRTs])-        case maybeFunClosure of-          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])-            where-              withLabels =-                [ (b, if b == staticFunBlock then lbl else staticFunLbl)-                | b <- blockids ]-          Nothing -> do-            updateSRTMap (Just one)-            return ([], map (,lbl) blockids, [])--    cafList ->-      -- Check whether an SRT with the same entries has been emitted already.-      -- Implements the [Common] optimisation.-      case Map.lookup filtered (dedupSRTs topSRT) of-        Just srtEntry@(SRTEntry srtLbl)  -> do-          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()-          updateSRTMap (Just srtEntry)-          return ([], map (,srtLbl) blockids, [])-        Nothing -> do-          -- No duplicates: we have to build a new SRT object-          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()-          (decls, funSRTs, srtEntry) <--            case maybeFunClosure of-              Just (fun,block) ->-                return ( [], [(block, cafList)], SRTEntry fun )-              Nothing -> do-                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList-                return (decls, [], entry)-          updateSRTMap (Just srtEntry)-          let allBelowThis = Set.union allBelow filtered-              oldFlatSRTs = flatSRTs topSRT-              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs-              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)-          lift (put (topSRT { dedupSRTs = newDedupSRTs-                            , flatSRTs = newFlatSRTs }))-          let SRTEntry lbl = srtEntry-          return (decls, map (,lbl) blockids, funSRTs)----- | build a static SRT object (or a chain of objects) from a list of--- SRTEntries.-buildSRTChain-   :: DynFlags-   -> [SRTEntry]-   -> UniqSM-        ( [CmmDecl]    -- The SRT object(s)-        , SRTEntry     -- label to use in the info table-        )-buildSRTChain _ [] = panic "buildSRT: empty"-buildSRTChain dflags cafSet =-  case splitAt mAX_SRT_SIZE cafSet of-    (these, []) -> do-      (decl,lbl) <- buildSRT dflags these-      return ([decl], lbl)-    (these,those) -> do-      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)-      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)-      return (decl:rest, lbl)-  where-    mAX_SRT_SIZE = 16---buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)-buildSRT dflags refs = do-  id <- getUniqueM-  let-    lbl = mkSRTLabel id-    srt_n_info = mkSRTInfoLabel (length refs)-    fields =-      mkStaticClosure dflags srt_n_info dontCareCCS-        [ CmmLabel lbl | SRTEntry lbl <- refs ]-        [] -- no padding-        [mkIntCLit dflags 0] -- link field-        [] -- no saved info-  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)----- | Update info tables with references to their SRTs. Also generate--- static closures, splicing in SRT fields as necessary.-updInfoSRTs-  :: DynFlags-  -> LabelMap CLabel               -- SRT labels for each block-  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures-  -> CmmDecl-  -> [CmmDecl]--updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)-  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]-  | otherwise = [ proc ]-  where-    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g-    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)-    updInfoTbl l info_tbl-      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf-      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }--    -- Generate static closures [FUN].  Note that this also generates-    -- static closures for thunks (CAFs), because it's easier to treat-    -- them uniformly in the code generator.-    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)-    maybeStaticClosure-      | Just info_tbl@CmmInfoTable{..} <--           mapLookup (g_entry g) (info_tbls top_info)-      , Just (id, ccs) <- cit_clo-      , isStaticRep cit_rep =-        let-          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of-            Nothing ->-              -- if we don't add SRT entries to this closure, then we-              -- want to set the srt field in its info table as usual-              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])-            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)-              (info_tbl { cit_rep = new_rep }, res)-              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]-          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)-            srtEntries-          new_rep = case cit_rep of-             HeapRep sta ptrs nptrs ty ->-               HeapRep sta (ptrs + length srtEntries) nptrs ty-             _other -> panic "maybeStaticFun"-          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)-        in-          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)-      | otherwise = Nothing--updInfoSRTs _ _ _ t = [t]---srtTrace :: String -> SDoc -> b -> b--- srtTrace = pprTrace-srtTrace _ _ b = b
− compiler/cmm/CmmCallConv.hs 
@@ -1,212 +0,0 @@-module CmmCallConv (-  ParamLocation(..),-  assignArgumentsPos,-  assignStack,-  realArgRegsCover-) where--import GhcPrelude--import CmmExpr-import SMRep-import Cmm (Convention(..))-import PprCmm () -- For Outputable instances--import DynFlags-import GHC.Platform-import Outputable---- Calculate the 'GlobalReg' or stack locations for function call--- parameters as used by the Cmm calling convention.--data ParamLocation-  = RegisterParam GlobalReg-  | StackParam ByteOff--instance Outputable ParamLocation where-  ppr (RegisterParam g) = ppr g-  ppr (StackParam p)    = ppr p---- |--- Given a list of arguments, and a function that tells their types,--- return a list showing where each argument is passed----assignArgumentsPos :: DynFlags-                   -> ByteOff           -- stack offset to start with-                   -> Convention-                   -> (a -> CmmType)    -- how to get a type from an arg-                   -> [a]               -- args-                   -> (-                        ByteOff              -- bytes of stack args-                      , [(a, ParamLocation)] -- args and locations-                      )--assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)-    where-      regs = case (reps, conv) of-               (_,   NativeNodeCall)   -> getRegsWithNode dflags-               (_,   NativeDirectCall) -> getRegsWithoutNode dflags-               ([_], NativeReturn)     -> allRegs dflags-               (_,   NativeReturn)     -> getRegsWithNode dflags-               -- GC calling convention *must* put values in registers-               (_,   GC)               -> allRegs dflags-               (_,   Slow)             -> nodeOnly-      -- The calling conventions first assign arguments to registers,-      -- then switch to the stack when we first run out of registers-      -- (even if there are still available registers for args of a-      -- different type).  When returning an unboxed tuple, we also-      -- separate the stack arguments by pointerhood.-      (reg_assts, stk_args)  = assign_regs [] reps regs-      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args-      assignments = reg_assts ++ stk_assts--      assign_regs assts []     _    = (assts, [])-      assign_regs assts (r:rs) regs | isVecType ty   = vec-                                    | isFloatType ty = float-                                    | otherwise      = int-        where vec = case (w, regs) of-                      (W128, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))-                      (W256, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))-                      (W512, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))-                      _ -> (assts, (r:rs))-              float = case (w, regs) of-                        (W32, (vs, fs, ds, ls, s:ss))-                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))-                        (W32, (vs, f:fs, ds, ls, ss))-                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))-                        (W64, (vs, fs, ds, ls, s:ss))-                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))-                        (W64, (vs, fs, d:ds, ls, ss))-                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))-                        _ -> (assts, (r:rs))-              int = case (w, regs) of-                      (W128, _) -> panic "W128 unsupported register type"-                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)-                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))-                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)-                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))-                      _   -> (assts, (r:rs))-              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'-              ty = arg_ty r-              w  = typeWidth ty-              gcp | isGcPtrType ty = VGcPtr-                  | otherwise      = VNonGcPtr-              passFloatInXmm = passFloatArgsInXmm dflags--passFloatArgsInXmm :: DynFlags -> Bool-passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of-                              ArchX86_64 -> True-                              ArchX86    -> False-                              _          -> False---- We used to spill vector registers to the stack since the LLVM backend didn't--- support vector registers in its calling convention. However, this has now--- been fixed. This function remains only as a convenient way to re-enable--- spilling when debugging code generation.-passVectorInReg :: Width -> DynFlags -> Bool-passVectorInReg _ _ = True--assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]-            -> (-                 ByteOff              -- bytes of stack args-               , [(a, ParamLocation)] -- args and locations-               )-assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)- where-      assign_stk offset assts [] = (offset, assts)-      assign_stk offset assts (r:rs)-        = assign_stk off' ((r, StackParam off') : assts) rs-        where w    = typeWidth (arg_ty r)-              off' = offset + size-              -- Stack arguments always take a whole number of words, we never-              -- pack them unlike constructor fields.-              size = roundUpToWords dflags (widthInBytes w)---------------------------------------------------------------------------------- Local information about the registers available--type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.-                 , [GlobalReg]   -- floats-                 , [GlobalReg]   -- doubles-                 , [GlobalReg]   -- longs (int64 and word64)-                 , [Int]         -- XMM (floats and doubles)-                 )---- Vanilla registers can contain pointers, Ints, Chars.--- Floats and doubles have separate register supplies.------ We take these register supplies from the *real* registers, i.e. those--- that are guaranteed to map to machine registers.--getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs-getRegsWithoutNode dflags =-  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)-  , realFloatRegs dflags-  , realDoubleRegs dflags-  , realLongRegs dflags-  , realXmmRegNos dflags)---- getRegsWithNode uses R1/node even if it isn't a register-getRegsWithNode dflags =-  ( if null (realVanillaRegs dflags)-    then [VanillaReg 1]-    else realVanillaRegs dflags-  , realFloatRegs dflags-  , realDoubleRegs dflags-  , realLongRegs dflags-  , realXmmRegNos dflags)--allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]-allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]-allXmmRegs :: DynFlags -> [Int]--allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)-allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)-allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)-allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)-allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)--realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]-realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]-realXmmRegNos :: DynFlags -> [Int]--realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)-realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)-realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)-realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)--realXmmRegNos dflags-    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)-    | otherwise            = []--regList :: Int -> [Int]-regList n = [1 .. n]--allRegs :: DynFlags -> AvailRegs-allRegs dflags = (allVanillaRegs dflags,-                  allFloatRegs dflags,-                  allDoubleRegs dflags,-                  allLongRegs dflags,-                  allXmmRegs dflags)--nodeOnly :: AvailRegs-nodeOnly = ([VanillaReg 1], [], [], [], [])---- This returns the set of global registers that *cover* the machine registers--- used for argument passing. On platforms where registers can overlap---right--- now just x86-64, where Float and Double registers overlap---passing this set--- of registers is guaranteed to preserve the contents of all live registers. We--- only use this functionality in hand-written C-- code in the RTS.-realArgRegsCover :: DynFlags -> [GlobalReg]-realArgRegsCover dflags-    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++-                                  realLongRegs dflags ++-                                  map XmmReg (realXmmRegNos dflags)-    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++-                                  realFloatRegs dflags ++-                                  realDoubleRegs dflags ++-                                  realLongRegs dflags ++-                                  map XmmReg (realXmmRegNos dflags)
− compiler/cmm/CmmCommonBlockElim.hs 
@@ -1,320 +0,0 @@-{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}--module CmmCommonBlockElim-  ( elimCommonBlocks-  )-where---import GhcPrelude hiding (iterate, succ, unzip, zip)--import BlockId-import Cmm-import CmmUtils-import CmmSwitch (eqSwitchTargetWith)-import CmmContFlowOpt--import Hoopl.Block-import Hoopl.Graph-import Hoopl.Label-import Hoopl.Collections-import Data.Bits-import Data.Maybe (mapMaybe)-import qualified Data.List as List-import Data.Word-import qualified Data.Map as M-import Outputable-import qualified TrieMap as TM-import UniqFM-import Unique-import Control.Arrow (first, second)---- -------------------------------------------------------------------------------- Eliminate common blocks---- If two blocks are identical except for the label on the first node,--- then we can eliminate one of the blocks. To ensure that the semantics--- of the program are preserved, we have to rewrite each predecessor of the--- eliminated block to proceed with the block we keep.---- The algorithm iterates over the blocks in the graph,--- checking whether it has seen another block that is equal modulo labels.--- If so, then it adds an entry in a map indicating that the new block--- is made redundant by the old block.--- Otherwise, it is added to the useful blocks.---- To avoid comparing every block with every other block repeatedly, we group--- them by---   * a hash of the block, ignoring labels (explained below)---   * the list of outgoing labels--- The hash is invariant under relabeling, so we only ever compare within--- the same group of blocks.------ The list of outgoing labels is updated as we merge blocks (that is why they--- are not included in the hash, which we want to calculate only once).------ All in all, two blocks should never be compared if they have different--- hashes, and at most once otherwise. Previously, we were slower, and people--- rightfully complained: #10397---- TODO: Use optimization fuel-elimCommonBlocks :: CmmGraph -> CmmGraph-elimCommonBlocks g = replaceLabels env $ copyTicks env g-  where-     env = iterate mapEmpty blocks_with_key-     -- The order of blocks doesn't matter here. While we could use-     -- revPostorder which drops unreachable blocks this is done in-     -- ContFlowOpt already which runs before this pass. So we use-     -- toBlockList since it is faster.-     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]-     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]---- Invariant: The blocks in the list are pairwise distinct--- (so avoid comparing them again)-type DistinctBlocks = [CmmBlock]-type Key = [Label]-type Subst = LabelMap BlockId---- The outer list groups by hash. We retain this grouping throughout.-iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst-iterate subst blocks-    | mapNull new_substs = subst-    | otherwise = iterate subst' updated_blocks-  where-    grouped_blocks :: [[(Key, [DistinctBlocks])]]-    grouped_blocks = map groupByLabel blocks--    merged_blocks :: [[(Key, DistinctBlocks)]]-    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks-      where-        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))-          where-            (new_subst2, db) = mergeBlockList subst dbs--    subst' = subst `mapUnion` new_substs-    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks---- Combine two lists of blocks.--- While they are internally distinct they can still share common blocks.-mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)-mergeBlocks subst existing new = go new-  where-    go [] = (mapEmpty, existing)-    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of-        -- This block is a duplicate. Drop it, and add it to the substitution-        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs-        -- This block is not a duplicate, keep it.-        Nothing -> second (b:) $ go bs--mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)-mergeBlockList _ [] = pprPanic "mergeBlockList" empty-mergeBlockList subst (b:bs) = go mapEmpty b bs-  where-    go !new_subst1 b [] = (new_subst1, b)-    go !new_subst1 b1 (b2:bs) = go new_subst b bs-      where-        (new_subst2, b) =  mergeBlocks subst b1 b2-        new_subst = new_subst1 `mapUnion` new_subst2----- -------------------------------------------------------------------------------- Hashing and equality on blocks---- Below here is mostly boilerplate: hashing blocks ignoring labels,--- and comparing blocks modulo a label mapping.---- To speed up comparisons, we hash each basic block modulo jump labels.--- The hashing is a bit arbitrary (the numbers are completely arbitrary),--- but it should be fast and good enough.---- We want to get as many small buckets as possible, as comparing blocks is--- expensive. So include as much as possible in the hash. Ideally everything--- that is compared with (==) in eqBlockBodyWith.--type HashCode = Int--hash_block :: CmmBlock -> HashCode-hash_block block =-  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))-  -- UniqFM doesn't like negative Ints-  where hash_fst _ h = h-        hash_mid m h = hash_node m + h `shiftL` 1-        hash_lst m h = hash_node m + h `shiftL` 1--        hash_node :: CmmNode O x -> Word32-        hash_node n | dont_care n = 0 -- don't care-        hash_node (CmmAssign r e) = hash_reg r + hash_e e-        hash_node (CmmStore e e') = hash_e e + hash_e e'-        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as-        hash_node (CmmBranch _) = 23 -- NB. ignore the label-        hash_node (CmmCondBranch p _ _ _) = hash_e p-        hash_node (CmmCall e _ _ _ _ _) = hash_e e-        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t-        hash_node (CmmSwitch e _) = hash_e e-        hash_node _ = error "hash_node: unknown Cmm node!"--        hash_reg :: CmmReg -> Word32-        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397-        hash_reg   (CmmGlobal _)    = 19--        hash_e :: CmmExpr -> Word32-        hash_e (CmmLit l) = hash_lit l-        hash_e (CmmLoad e _) = 67 + hash_e e-        hash_e (CmmReg r) = hash_reg r-        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check-        hash_e (CmmRegOff r i) = hash_reg r + cvt i-        hash_e (CmmStackSlot _ _) = 13--        hash_lit :: CmmLit -> Word32-        hash_lit (CmmInt i _) = fromInteger i-        hash_lit (CmmFloat r _) = truncate r-        hash_lit (CmmVec ls) = hash_list hash_lit ls-        hash_lit (CmmLabel _) = 119 -- ugh-        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i-        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i-        hash_lit (CmmBlock _) = 191 -- ugh-        hash_lit (CmmHighStackMark) = cvt 313--        hash_tgt (ForeignTarget e _) = hash_e e-        hash_tgt (PrimTarget _) = 31 -- lots of these--        hash_list f = foldl' (\z x -> f x + z) (0::Word32)--        cvt = fromInteger . toInteger--        hash_unique :: Uniquable a => a -> Word32-        hash_unique = cvt . getKey . getUnique---- | Ignore these node types for equality-dont_care :: CmmNode O x -> Bool-dont_care CmmComment {}  = True-dont_care CmmTick {}     = True-dont_care CmmUnwind {}   = True-dont_care _other         = False---- Utilities: equality and substitution on the graph.---- Given a map ``subst'' from BlockID -> BlockID, we define equality.-eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool-eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'-lookupBid :: LabelMap BlockId -> BlockId -> BlockId-lookupBid subst bid = case mapLookup bid subst of-                        Just bid  -> lookupBid subst bid-                        Nothing -> bid---- Middle nodes and expressions can contain BlockIds, in particular in--- CmmStackSlot and CmmBlock, so we have to use a special equality for--- these.----eqMiddleWith :: (BlockId -> BlockId -> Bool)-             -> CmmNode O O -> CmmNode O O -> Bool-eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)-  = r1 == r2 && eqExprWith eqBid e1 e2-eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)-  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2-eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)-                   (CmmUnsafeForeignCall t2 r2 a2)-  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2-eqMiddleWith _ _ _ = False--eqExprWith :: (BlockId -> BlockId -> Bool)-           -> CmmExpr -> CmmExpr -> Bool-eqExprWith eqBid = eq- where-  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2-  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2-  CmmReg r1          `eq` CmmReg r2          = r1==r2-  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2-  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2-  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2-  _e1                `eq` _e2                = False--  xs `eqs` ys = eqListWith eq xs ys--  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2-  eqLit l1 l2 = l1 == l2--  eqArea Old Old = True-  eqArea (Young id1) (Young id2) = eqBid id1 id2-  eqArea _ _ = False---- Equality on the body of a block, modulo a function mapping block--- IDs to block IDs.-eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool-eqBlockBodyWith eqBid block block'-  {--  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True-  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False-  -}-  = equal-  where (_,m,l)   = blockSplit block-        nodes     = filter (not . dont_care) (blockToList m)-        (_,m',l') = blockSplit block'-        nodes'    = filter (not . dont_care) (blockToList m')--        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&-                eqLastWith eqBid l l'---eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool-eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2-eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =-  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2-eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =-  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2-eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =-  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2-eqLastWith _ _ _ = False--eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool-eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'-eqMaybeWith _ Nothing Nothing = True-eqMaybeWith _ _ _ = False--eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool-eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs-eqListWith _ []       []       = True-eqListWith _ _        _        = False---- | Given a block map, ensure that all "target" blocks are covered by--- the same ticks as the respective "source" blocks. This not only--- means copying ticks, but also adjusting tick scopes where--- necessary.-copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph-copyTicks env g-  | mapNull env = g-  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap-  where -- Reverse block merge map-        blockMap = toBlockMap g-        revEnv = mapFoldlWithKey insertRev M.empty env-        insertRev m k x = M.insertWith (const (k:)) x [k] m-        -- Copy ticks and scopes into the given block-        copyTo block = case M.lookup (entryLabel block) revEnv of-          Nothing -> block-          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls-        copy from to =-          let ticks = blockTicks from-              CmmEntry  _   scp0        = firstNode from-              (CmmEntry lbl scp1, code) = blockSplitHead to-          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`-             foldr blockCons code (map CmmTick ticks)---- Group by [Label]--- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.-groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]-groupByLabel =-  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))-    where-      go !m [] = TM.foldTM (:) m []-      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries-        where --k' = map (getKey . getUnique) k-              adjust Nothing       = Just (k,[v])-              adjust (Just (_,vs)) = Just (k,v:vs)--groupByInt :: (a -> Int) -> [a] -> [[a]]-groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs-   -- See Note [Unique Determinism and code generation]-  where-    go m x = alterUFM addEntry m (f x)-      where-        addEntry xs = Just $! maybe [x] (x:) xs
− compiler/cmm/CmmContFlowOpt.hs 
@@ -1,451 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-module CmmContFlowOpt-    ( cmmCfgOpts-    , cmmCfgOptsProc-    , removeUnreachableBlocksProc-    , replaceLabels-    )-where--import GhcPrelude hiding (succ, unzip, zip)--import Hoopl.Block-import Hoopl.Collections-import Hoopl.Graph-import Hoopl.Label-import BlockId-import Cmm-import CmmUtils-import CmmSwitch (mapSwitchTargets, switchTargetsToList)-import Maybes-import Panic-import Util--import Control.Monad----- Note [What is shortcutting]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Consider this Cmm code:------ L1: ...---     goto L2;--- L2: goto L3;--- L3: ...------ Here L2 is an empty block and contains only an unconditional branch--- to L3. In this situation any block that jumps to L2 can jump--- directly to L3:------ L1: ...---     goto L3;--- L2: goto L3;--- L3: ...------ In this situation we say that we shortcut L2 to L3. One of--- consequences of shortcutting is that some blocks of code may become--- unreachable (in the example above this is true for L2).----- Note [Control-flow optimisations]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ This optimisation does three things:------   - If a block finishes in an unconditional branch to another block---     and that is the only jump to that block we concatenate the---     destination block at the end of the current one.------   - If a block finishes in a call whose continuation block is a---     goto, then we can shortcut the destination, making the---     continuation block the destination of the goto - but see Note---     [Shortcut call returns].------   - For any block that is not a call we try to shortcut the---     destination(s). Additionally, if a block ends with a---     conditional branch we try to invert the condition.------ Blocks are processed using postorder DFS traversal. A side effect--- of determining traversal order with a graph search is elimination--- of any blocks that are unreachable.------ Transformations are improved by working from the end of the graph--- towards the beginning, because we may be able to perform many--- shortcuts in one go.----- Note [Shortcut call returns]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ We are going to maintain the "current" graph (LabelMap CmmBlock) as--- we go, and also a mapping from BlockId to BlockId, representing--- continuation labels that we have renamed.  This latter mapping is--- important because we might shortcut a CmmCall continuation.  For--- example:------    Sp[0] = L---    call g returns to L---    L: goto M---    M: ...------ So when we shortcut the L block, we need to replace not only--- the continuation of the call, but also references to L in the--- code (e.g. the assignment Sp[0] = L):------    Sp[0] = M---    call g returns to M---    M: ...------ So we keep track of which labels we have renamed and apply the mapping--- at the end with replaceLabels.----- Note [Shortcut call returns and proc-points]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Consider this code that you might get from a recursive--- let-no-escape:------       goto L1---      L1:---       if (Hp > HpLim) then L2 else L3---      L2:---       call stg_gc_noregs returns to L4---      L4:---       goto L1---      L3:---       ...---       goto L1------ Then the control-flow optimiser shortcuts L4.  But that turns L1--- into the call-return proc point, and every iteration of the loop--- has to shuffle variables to and from the stack.  So we must *not*--- shortcut L4.------ Moreover not shortcutting call returns is probably fine.  If L4 can--- concat with its branch target then it will still do so.  And we--- save some compile time because we don't have to traverse all the--- code in replaceLabels.------ However, we probably do want to do this if we are splitting proc--- points, because L1 will be a proc-point anyway, so merging it with--- L4 reduces the number of proc points.  Unfortunately recursive--- let-no-escapes won't generate very good code with proc-point--- splitting on - we should probably compile them to explicitly use--- the native calling convention instead.--cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph-cmmCfgOpts split g = fst (blockConcat split g)--cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl-cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'-    where (g', env) = blockConcat split g-          info' = info{ info_tbls = new_info_tbls }-          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))--          -- If we changed any labels, then we have to update the info tables-          -- too, except for the top-level info table because that might be-          -- referred to by other procs.-          upd_info (k,info)-             | Just k' <- mapLookup k env-             = (k', if k' == g_entry g'-                       then info-                       else info{ cit_lbl = infoTblLbl k' })-             | otherwise-             = (k,info)-cmmCfgOptsProc _ top = top---blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)-blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }-  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')-  where-     -- We might be able to shortcut the entry BlockId itself.-     -- Remember to update the shortcut_map, since we also have to-     -- update the info_tbls mapping now.-     (new_entry, shortcut_map')-       | Just entry_blk <- mapLookup entry_id new_blocks-       , Just dest      <- canShortcut entry_blk-       = (dest, mapInsert entry_id dest shortcut_map)-       | otherwise-       = (entry_id, shortcut_map)--     -- blocks are sorted in reverse postorder, but we want to go from the exit-     -- towards beginning, so we use foldr below.-     blocks = revPostorder g-     blockmap = foldl' (flip addBlock) emptyBody blocks--     -- Accumulator contains three components:-     --  * map of blocks in a graph-     --  * map of shortcut labels. See Note [Shortcut call returns]-     --  * map containing number of predecessors for each block. We discard-     --    it after we process all blocks.-     (new_blocks, shortcut_map, _) =-           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks--     -- Map of predecessors for initial graph. We increase number of-     -- predecessors for entry block by one to denote that it is-     -- target of a jump, even if no block in the current graph jumps-     -- to it.-     initialBackEdges = incPreds entry_id (predMap blocks)--     maybe_concat :: CmmBlock-                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)-                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)-     maybe_concat block (!blocks, !shortcut_map, !backEdges)-        -- If:-        --   (1) current block ends with unconditional branch to b' and-        --   (2) it has exactly one predecessor (namely, current block)-        ---        -- Then:-        --   (1) append b' block at the end of current block-        --   (2) remove b' from the map of blocks-        --   (3) remove information about b' from predecessors map-        ---        -- Since we know that the block has only one predecessor we call-        -- mapDelete directly instead of calling decPreds.-        ---        -- Note that we always maintain an up-to-date list of predecessors, so-        -- we can ignore the contents of shortcut_map-        | CmmBranch b' <- last-        , hasOnePredecessor b'-        , Just blk' <- mapLookup b' blocks-        = let bid' = entryLabel blk'-          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks-             , shortcut_map-             , mapDelete b' backEdges )--        -- If:-        --   (1) we are splitting proc points (see Note-        --       [Shortcut call returns and proc-points]) and-        --   (2) current block is a CmmCall or CmmForeignCall with-        --       continuation b' and-        --   (3) we can shortcut that continuation to dest-        -- Then:-        --   (1) we change continuation to point to b'-        --   (2) create mapping from b' to dest-        --   (3) increase number of predecessors of dest by 1-        --   (4) decrease number of predecessors of b' by 1-        ---        -- Later we will use replaceLabels to substitute all occurrences of b'-        -- with dest.-        | splitting_procs-        , Just b'   <- callContinuation_maybe last-        , Just blk' <- mapLookup b' blocks-        , Just dest <- canShortcut blk'-        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks-          , mapInsert b' dest shortcut_map-          , decPreds b' $ incPreds dest backEdges )--        -- If:-        --   (1) a block does not end with a call-        -- Then:-        --   (1) if it ends with a conditional attempt to invert the-        --       conditional-        --   (2) attempt to shortcut all destination blocks-        --   (3) if new successors of a block are different from the old ones-        --       update the of predecessors accordingly-        ---        -- A special case of this is a situation when a block ends with an-        -- unconditional jump to a block that can be shortcut.-        | Nothing <- callContinuation_maybe last-        = let oldSuccs = successors last-              newSuccs = successors rewrite_last-          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks-             , shortcut_map-             , if oldSuccs == newSuccs-               then backEdges-               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )--        -- Otherwise don't do anything-        | otherwise-        = ( blocks, shortcut_map, backEdges )-        where-          (head, last) = blockSplitTail block-          bid = entryLabel block--          -- Changes continuation of a call to a specified label-          update_cont dest =-              case last of-                CmmCall{}        -> last { cml_cont = Just dest }-                CmmForeignCall{} -> last { succ = dest }-                _                -> panic "Can't shortcut continuation."--          -- Attempts to shortcut successors of last node-          shortcut_last = mapSuccessors shortcut last-            where-              shortcut l =-                 case mapLookup l blocks of-                   Just b | Just dest <- canShortcut b -> dest-                   _otherwise -> l--          rewrite_last-            -- Sometimes we can get rid of the conditional completely.-            | CmmCondBranch _cond t f _l <- shortcut_last-            , t == f-            = CmmBranch t--            -- See Note [Invert Cmm conditionals]-            | CmmCondBranch cond t f l <- shortcut_last-            , hasOnePredecessor t -- inverting will make t a fallthrough-            , likelyTrue l || (numPreds f > 1)-            , Just cond' <- maybeInvertCmmExpr cond-            = CmmCondBranch cond' f t (invertLikeliness l)--            -- If all jump destinations of a switch go to the-            -- same target eliminate the switch.-            | CmmSwitch _expr targets <- shortcut_last-            , (t:ts) <- switchTargetsToList targets-            , all (== t) ts-            = CmmBranch t--            | otherwise-            = shortcut_last--          likelyTrue (Just True)   = True-          likelyTrue _             = False--          invertLikeliness :: Maybe Bool -> Maybe Bool-          invertLikeliness         = fmap not--          -- Number of predecessors for a block-          numPreds bid = mapLookup bid backEdges `orElse` 0--          hasOnePredecessor b = numPreds b == 1--{--  Note [Invert Cmm conditionals]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  The native code generator always produces jumps to the true branch.-  Falling through to the false branch is however faster. So we try to-  arrange for that to happen.-  This means we invert the condition if:-  * The likely path will become a fallthrough.-  * We can't guarantee a fallthrough for the false branch but for the-    true branch.--  In some cases it's faster to avoid inverting when the false branch is likely.-  However determining when that is the case is neither easy nor cheap so for-  now we always invert as this produces smaller binaries and code that is-  equally fast on average. (On an i7-6700K)--  TODO:-  There is also the edge case when both branches have multiple predecessors.-  In this case we could assume that we will end up with a jump for BOTH-  branches. In this case it might be best to put the likely path in the true-  branch especially if there are large numbers of predecessors as this saves-  us the jump thats not taken. However I haven't tested this and as of early-  2018 we almost never generate cmm where this would apply.--}---- Functions for incrementing and decrementing number of predecessors. If--- decrementing would set the predecessor count to 0, we remove entry from the--- map.--- Invariant: if a block has no predecessors it should be dropped from the--- graph because it is unreachable. maybe_concat is constructed to maintain--- that invariant, but calling replaceLabels may introduce unreachable blocks.--- We rely on subsequent passes in the Cmm pipeline to remove unreachable--- blocks.-incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int-incPreds bid edges = mapInsertWith (+) bid 1 edges-decPreds bid edges = case mapLookup bid edges of-                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges-                       Just _                 -> mapDelete bid edges-                       _                      -> edges----- Checks if a block consists only of "goto dest". If it does than we return--- "Just dest" label. See Note [What is shortcutting]-canShortcut :: CmmBlock -> Maybe BlockId-canShortcut block-    | (_, middle, CmmBranch dest) <- blockSplit block-    , all dont_care $ blockToList middle-    = Just dest-    | otherwise-    = Nothing-    where dont_care CmmComment{} = True-          dont_care CmmTick{}    = True-          dont_care _other       = False---- Concatenates two blocks. First one is assumed to be open on exit, the second--- is assumed to be closed on entry (i.e. it has a label attached to it, which--- the splice function removes by calling snd on result of blockSplitHead).-splice :: Block CmmNode C O -> CmmBlock -> CmmBlock-splice head rest = entry `blockJoinHead` code0 `blockAppend` code1-  where (CmmEntry lbl sc0, code0) = blockSplitHead head-        (CmmEntry _   sc1, code1) = blockSplitHead rest-        entry = CmmEntry lbl (combineTickScopes sc0 sc1)---- If node is a call with continuation call return Just label of that--- continuation. Otherwise return Nothing.-callContinuation_maybe :: CmmNode O C -> Maybe BlockId-callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b-callContinuation_maybe (CmmForeignCall { succ = b })   = Just b-callContinuation_maybe _ = Nothing----- Map over the CmmGraph, replacing each label with its mapping in the--- supplied LabelMap.-replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph-replaceLabels env g-  | mapNull env = g-  | otherwise   = replace_eid $ mapGraphNodes1 txnode g-   where-     replace_eid g = g {g_entry = lookup (g_entry g)}-     lookup id = mapLookup id env `orElse` id--     txnode :: CmmNode e x -> CmmNode e x-     txnode (CmmBranch bid) = CmmBranch (lookup bid)-     txnode (CmmCondBranch p t f l) =-       mkCmmCondBranch (exp p) (lookup t) (lookup f) l-     txnode (CmmSwitch e ids) =-       CmmSwitch (exp e) (mapSwitchTargets lookup ids)-     txnode (CmmCall t k rg a res r) =-       CmmCall (exp t) (liftM lookup k) rg a res r-     txnode fc@CmmForeignCall{} =-       fc{ args = map exp (args fc), succ = lookup (succ fc) }-     txnode other = mapExpDeep exp other--     exp :: CmmExpr -> CmmExpr-     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))-     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i-     exp e                                      = e--mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C-mkCmmCondBranch p t f l =-  if t == f then CmmBranch t else CmmCondBranch p t f l---- Build a map from a block to its set of predecessors.-predMap :: [CmmBlock] -> LabelMap Int-predMap blocks = foldr add_preds mapEmpty blocks-  where-    add_preds block env = foldr add env (successors block)-      where add lbl env = mapInsertWith (+) lbl 1 env---- Removing unreachable blocks-removeUnreachableBlocksProc :: CmmDecl -> CmmDecl-removeUnreachableBlocksProc proc@(CmmProc info lbl live g)-   | used_blocks `lengthLessThan` mapSize (toBlockMap g)-   = CmmProc info' lbl live g'-   | otherwise-   = proc-   where-     g'    = ofBlockList (g_entry g) used_blocks-     info' = info { info_tbls = keep_used (info_tbls info) }-             -- Remove any info_tbls for unreachable--     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable-     keep_used bs = mapFoldlWithKey keep mapEmpty bs--     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable-     keep env l i | l `setMember` used_lbls = mapInsert l i env-                  | otherwise               = env--     used_blocks :: [CmmBlock]-     used_blocks = revPostorder g--     used_lbls :: LabelSet-     used_lbls = setFromList $ map entryLabel used_blocks
− compiler/cmm/CmmExpr.hs 
@@ -1,619 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--module CmmExpr-    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr-    , CmmReg(..), cmmRegType, cmmRegWidth-    , CmmLit(..), cmmLitType-    , LocalReg(..), localRegType-    , GlobalReg(..), isArgReg, globalRegType-    , spReg, hpReg, spLimReg, hpLimReg, nodeReg-    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg-    , node, baseReg-    , VGcPtr(..)--    , DefinerOfRegs, UserOfRegs-    , foldRegsDefd, foldRegsUsed-    , foldLocalRegsDefd, foldLocalRegsUsed--    , RegSet, LocalRegSet, GlobalRegSet-    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet-    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet-    , regSetToList--    , Area(..)-    , module CmmMachOp-    , module CmmType-    )-where--import GhcPrelude--import BlockId-import CLabel-import CmmMachOp-import CmmType-import DynFlags-import Outputable (panic)-import Unique--import Data.Set (Set)-import qualified Data.Set as Set--import BasicTypes (Alignment, mkAlignment, alignmentOf)----------------------------------------------------------------------------------              CmmExpr--- An expression.  Expressions have no side effects.--------------------------------------------------------------------------------data CmmExpr-  = CmmLit CmmLit               -- Literal-  | CmmLoad !CmmExpr !CmmType   -- Read memory location-  | CmmReg !CmmReg              -- Contents of register-  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)-  | CmmStackSlot Area {-# UNPACK #-} !Int-                                -- addressing expression of a stack slot-                                -- See Note [CmmStackSlot aliasing]-  | CmmRegOff !CmmReg Int-        -- CmmRegOff reg i-        --        ** is shorthand only, meaning **-        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]-        --      where rep = typeWidth (cmmRegType reg)--instance Eq CmmExpr where       -- Equality ignores the types-  CmmLit l1          == CmmLit l2          = l1==l2-  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2-  CmmReg r1          == CmmReg r2          = r1==r2-  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2-  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2-  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2-  _e1                == _e2                = False--data CmmReg-  = CmmLocal  {-# UNPACK #-} !LocalReg-  | CmmGlobal GlobalReg-  deriving( Eq, Ord )---- | A stack area is either the stack slot where a variable is spilled--- or the stack space where function arguments and results are passed.-data Area-  = Old            -- See Note [Old Area]-  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId-                   -- See Note [Continuation BlockId] in CmmNode.-  deriving (Eq, Ord)--{- Note [Old Area]-~~~~~~~~~~~~~~~~~~-There is a single call area 'Old', allocated at the extreme old-end of the stack frame (ie just younger than the return address)-which holds:-  * incoming (overflow) parameters,-  * outgoing (overflow) parameter to tail calls,-  * outgoing (overflow) result values-  * the update frame (if any)--Its size is the max of all these requirements.  On entry, the stack-pointer will point to the youngest incoming parameter, which is not-necessarily at the young end of the Old area.--End of note -}---{- Note [CmmStackSlot aliasing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When do two CmmStackSlots alias?-- - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M- - T[old+N] aliases with U[old+M] only if the areas actually overlap--Or more informally, different Areas may overlap with each other.--An alternative semantics, that we previously had, was that different-Areas do not overlap.  The problem that lead to redefining the-semantics of stack areas is described below.--e.g. if we had--    x = Sp[old + 8]-    y = Sp[old + 16]--    Sp[young(L) + 8]  = L-    Sp[young(L) + 16] = y-    Sp[young(L) + 24] = x-    call f() returns to L--if areas semantically do not overlap, then we might optimise this to--    Sp[young(L) + 8]  = L-    Sp[young(L) + 16] = Sp[old + 8]-    Sp[young(L) + 24] = Sp[old + 16]-    call f() returns to L--and now young(L) cannot be allocated at the same place as old, and we-are doomed to use more stack.--  - old+8  conflicts with young(L)+8-  - old+16 conflicts with young(L)+16 and young(L)+8--so young(L)+8 == old+24 and we get--    Sp[-8]  = L-    Sp[-16] = Sp[8]-    Sp[-24] = Sp[0]-    Sp -= 24-    call f() returns to L--However, if areas are defined to be "possibly overlapping" in the-semantics, then we cannot commute any loads/stores of old with-young(L), and we will be able to re-use both old+8 and old+16 for-young(L).--    x = Sp[8]-    y = Sp[0]--    Sp[8] = L-    Sp[0] = y-    Sp[-8] = x-    Sp = Sp - 8-    call f() returns to L--Now, the assignments of y go away,--    x = Sp[8]-    Sp[8] = L-    Sp[-8] = x-    Sp = Sp - 8-    call f() returns to L--}--data CmmLit-  = CmmInt !Integer  Width-        -- Interpretation: the 2's complement representation of the value-        -- is truncated to the specified size.  This is easier than trying-        -- to keep the value within range, because we don't know whether-        -- it will be used as a signed or unsigned value (the CmmType doesn't-        -- distinguish between signed & unsigned).-  | CmmFloat  Rational Width-  | CmmVec [CmmLit]                     -- Vector literal-  | CmmLabel    CLabel                  -- Address of label-  | CmmLabelOff CLabel Int              -- Address of label + byte offset--        -- Due to limitations in the C backend, the following-        -- MUST ONLY be used inside the info table indicated by label2-        -- (label2 must be the info label), and label1 must be an-        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)-        -- Don't use it at all unless tablesNextToCode.-        -- It is also used inside the NCG during when generating-        -- position-independent code.-  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset-        -- In an expression, the width just has the effect of MO_SS_Conv-        -- from wordWidth to the desired width.-        ---        -- In a static literal, the supported Widths depend on the-        -- architecture: wordWidth is supported on all-        -- architectures. Additionally W32 is supported on x86_64 when-        -- using the small memory model.--  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label-        -- Invariant: must be a continuation BlockId-        -- See Note [Continuation BlockId] in CmmNode.--  | CmmHighStackMark -- A late-bound constant that stands for the max-                     -- #bytes of stack space used during a procedure.-                     -- During the stack-layout pass, CmmHighStackMark-                     -- is replaced by a CmmInt for the actual number-                     -- of bytes used-  deriving Eq--cmmExprType :: DynFlags -> CmmExpr -> CmmType-cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit-cmmExprType _      (CmmLoad _ rep)     = rep-cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg-cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)-cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg-cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address--- Careful though: what is stored at the stack slot may be bigger than--- an address--cmmLitType :: DynFlags -> CmmLit -> CmmType-cmmLitType _      (CmmInt _ width)     = cmmBits  width-cmmLitType _      (CmmFloat _ width)   = cmmFloat width-cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"-cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l-                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)-                                            then cmmVec (1+length ls) ty-                                            else panic "cmmLitType: CmmVec"-cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl-cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl-cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width-cmmLitType dflags (CmmBlock _)         = bWord dflags-cmmLitType dflags (CmmHighStackMark)   = bWord dflags--cmmLabelType :: DynFlags -> CLabel -> CmmType-cmmLabelType dflags lbl- | isGcPtrLabel lbl = gcWord dflags- | otherwise        = bWord dflags--cmmExprWidth :: DynFlags -> CmmExpr -> Width-cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)---- | Returns an alignment in bytes of a CmmExpr when it's a statically--- known integer constant, otherwise returns an alignment of 1 byte.--- The caller is responsible for using with a sensible CmmExpr--- argument.-cmmExprAlignment :: CmmExpr -> Alignment-cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)-cmmExprAlignment _                          = mkAlignment 1------------- Negation for conditional branches--maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr-maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op-                                            return (CmmMachOp op' args)-maybeInvertCmmExpr _ = Nothing----------------------------------------------------------------------------------              Local registers--------------------------------------------------------------------------------data LocalReg-  = LocalReg {-# UNPACK #-} !Unique CmmType-    -- ^ Parameters:-    --   1. Identifier-    --   2. Type--instance Eq LocalReg where-  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2---- This is non-deterministic but we do not currently support deterministic--- code-generation. See Note [Unique Determinism and code generation]--- See Note [No Ord for Unique]-instance Ord LocalReg where-  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2--instance Uniquable LocalReg where-  getUnique (LocalReg uniq _) = uniq--cmmRegType :: DynFlags -> CmmReg -> CmmType-cmmRegType _      (CmmLocal  reg) = localRegType reg-cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg--cmmRegWidth :: DynFlags -> CmmReg -> Width-cmmRegWidth dflags = typeWidth . cmmRegType dflags--localRegType :: LocalReg -> CmmType-localRegType (LocalReg _ rep) = rep----------------------------------------------------------------------------------    Register-use information for expressions and other types---------------------------------------------------------------------------------- | Sets of registers---- These are used for dataflow facts, and a common operation is taking--- the union of two RegSets and then asking whether the union is the--- same as one of the inputs.  UniqSet isn't good here, because--- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary--- Sets.--type RegSet r     = Set r-type LocalRegSet  = RegSet LocalReg-type GlobalRegSet = RegSet GlobalReg--emptyRegSet             :: RegSet r-nullRegSet              :: RegSet r -> Bool-elemRegSet              :: Ord r => r -> RegSet r -> Bool-extendRegSet            :: Ord r => RegSet r -> r -> RegSet r-deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r-mkRegSet                :: Ord r => [r] -> RegSet r-minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r-sizeRegSet              :: RegSet r -> Int-regSetToList            :: RegSet r -> [r]--emptyRegSet      = Set.empty-nullRegSet       = Set.null-elemRegSet       = Set.member-extendRegSet     = flip Set.insert-deleteFromRegSet = flip Set.delete-mkRegSet         = Set.fromList-minusRegSet      = Set.difference-plusRegSet       = Set.union-timesRegSet      = Set.intersection-sizeRegSet       = Set.size-regSetToList     = Set.toList--class Ord r => UserOfRegs r a where-  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b--foldLocalRegsUsed :: UserOfRegs LocalReg a-                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b-foldLocalRegsUsed = foldRegsUsed--class Ord r => DefinerOfRegs r a where-  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b--foldLocalRegsDefd :: DefinerOfRegs LocalReg a-                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b-foldLocalRegsDefd = foldRegsDefd--instance UserOfRegs LocalReg CmmReg where-    foldRegsUsed _ f z (CmmLocal reg) = f z reg-    foldRegsUsed _ _ z (CmmGlobal _)  = z--instance DefinerOfRegs LocalReg CmmReg where-    foldRegsDefd _ f z (CmmLocal reg) = f z reg-    foldRegsDefd _ _ z (CmmGlobal _)  = z--instance UserOfRegs GlobalReg CmmReg where-    foldRegsUsed _ _ z (CmmLocal _)    = z-    foldRegsUsed _ f z (CmmGlobal reg) = f z reg--instance DefinerOfRegs GlobalReg CmmReg where-    foldRegsDefd _ _ z (CmmLocal _)    = z-    foldRegsDefd _ f z (CmmGlobal reg) = f z reg--instance Ord r => UserOfRegs r r where-    foldRegsUsed _ f z r = f z r--instance Ord r => DefinerOfRegs r r where-    foldRegsDefd _ f z r = f z r--instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where-  -- The (Ord r) in the context is necessary here-  -- See Note [Recursive superclasses] in TcInstDcls-  foldRegsUsed dflags f !z e = expr z e-    where expr z (CmmLit _)          = z-          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr-          expr z (CmmReg r)          = foldRegsUsed dflags f z r-          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs-          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r-          expr z (CmmStackSlot _ _)  = z--instance UserOfRegs r a => UserOfRegs r [a] where-  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as-  {-# INLINABLE foldRegsUsed #-}--instance DefinerOfRegs r a => DefinerOfRegs r [a] where-  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as-  {-# INLINABLE foldRegsDefd #-}----------------------------------------------------------------------------------              Global STG registers--------------------------------------------------------------------------------data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )----------------------------------------------------------------------------------              Global STG registers-------------------------------------------------------------------------------{--Note [Overlapping global registers]--The backend might not faithfully implement the abstraction of the STG-machine with independent registers for different values of type-GlobalReg. Specifically, certain pairs of registers (r1, r2) may-overlap in the sense that a store to r1 invalidates the value in r2,-and vice versa.--Currently this occurs only on the x86_64 architecture where FloatReg n-and DoubleReg n are assigned the same microarchitectural register, in-order to allow functions to receive more Float# or Double# arguments-in registers (as opposed to on the stack).--There are no specific rules about which registers might overlap with-which other registers, but presumably it's safe to assume that nothing-will overlap with special registers like Sp or BaseReg.--Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap-on a particular platform. The instance Eq GlobalReg is syntactic-equality of STG registers and does not take overlap into-account. However it is still used in UserOfRegs/DefinerOfRegs and-there are likely still bugs there, beware!--}--data GlobalReg-  -- Argument and return registers-  = VanillaReg                  -- pointers, unboxed ints and chars-        {-# UNPACK #-} !Int     -- its number-        VGcPtr--  | FloatReg            -- single-precision floating-point registers-        {-# UNPACK #-} !Int     -- its number--  | DoubleReg           -- double-precision floating-point registers-        {-# UNPACK #-} !Int     -- its number--  | LongReg             -- long int registers (64-bit, really)-        {-# UNPACK #-} !Int     -- its number--  | XmmReg                      -- 128-bit SIMD vector register-        {-# UNPACK #-} !Int     -- its number--  | YmmReg                      -- 256-bit SIMD vector register-        {-# UNPACK #-} !Int     -- its number--  | ZmmReg                      -- 512-bit SIMD vector register-        {-# UNPACK #-} !Int     -- its number--  -- STG registers-  | Sp                  -- Stack ptr; points to last occupied stack location.-  | SpLim               -- Stack limit-  | Hp                  -- Heap ptr; points to last occupied heap location.-  | HpLim               -- Heap limit register-  | CCCS                -- Current cost-centre stack-  | CurrentTSO          -- pointer to current thread's TSO-  | CurrentNursery      -- pointer to allocation area-  | HpAlloc             -- allocation count for heap check failure--                -- We keep the address of some commonly-called-                -- functions in the register table, to keep code-                -- size down:-  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info-  | GCEnter1            -- stg_gc_enter_1-  | GCFun               -- stg_gc_fun--  -- Base offset for the register table, used for accessing registers-  -- which do not have real registers assigned to them.  This register-  -- will only appear after we have expanded GlobalReg into memory accesses-  -- (where necessary) in the native code generator.-  | BaseReg--  -- The register used by the platform for the C stack pointer. This is-  -- a break in the STG abstraction used exclusively to setup stack unwinding-  -- information.-  | MachSp--  -- The is a dummy register used to indicate to the stack unwinder where-  -- a routine would return to.-  | UnwindReturnReg--  -- Base Register for PIC (position-independent code) calculations-  -- Only used inside the native code generator. It's exact meaning differs-  -- from platform to platform (see module PositionIndependentCode).-  | PicBaseReg--  deriving( Show )--instance Eq GlobalReg where-   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes-   FloatReg i == FloatReg j = i==j-   DoubleReg i == DoubleReg j = i==j-   LongReg i == LongReg j = i==j-   -- NOTE: XMM, YMM, ZMM registers actually are the same registers-   -- at least with respect to store at YMM i and then read from XMM i-   -- and similarly for ZMM etc.-   XmmReg i == XmmReg j = i==j-   YmmReg i == YmmReg j = i==j-   ZmmReg i == ZmmReg j = i==j-   Sp == Sp = True-   SpLim == SpLim = True-   Hp == Hp = True-   HpLim == HpLim = True-   CCCS == CCCS = True-   CurrentTSO == CurrentTSO = True-   CurrentNursery == CurrentNursery = True-   HpAlloc == HpAlloc = True-   EagerBlackholeInfo == EagerBlackholeInfo = True-   GCEnter1 == GCEnter1 = True-   GCFun == GCFun = True-   BaseReg == BaseReg = True-   MachSp == MachSp = True-   UnwindReturnReg == UnwindReturnReg = True-   PicBaseReg == PicBaseReg = True-   _r1 == _r2 = False--instance Ord GlobalReg where-   compare (VanillaReg i _) (VanillaReg j _) = compare i j-     -- Ignore type when seeking clashes-   compare (FloatReg i)  (FloatReg  j) = compare i j-   compare (DoubleReg i) (DoubleReg j) = compare i j-   compare (LongReg i)   (LongReg   j) = compare i j-   compare (XmmReg i)    (XmmReg    j) = compare i j-   compare (YmmReg i)    (YmmReg    j) = compare i j-   compare (ZmmReg i)    (ZmmReg    j) = compare i j-   compare Sp Sp = EQ-   compare SpLim SpLim = EQ-   compare Hp Hp = EQ-   compare HpLim HpLim = EQ-   compare CCCS CCCS = EQ-   compare CurrentTSO CurrentTSO = EQ-   compare CurrentNursery CurrentNursery = EQ-   compare HpAlloc HpAlloc = EQ-   compare EagerBlackholeInfo EagerBlackholeInfo = EQ-   compare GCEnter1 GCEnter1 = EQ-   compare GCFun GCFun = EQ-   compare BaseReg BaseReg = EQ-   compare MachSp MachSp = EQ-   compare UnwindReturnReg UnwindReturnReg = EQ-   compare PicBaseReg PicBaseReg = EQ-   compare (VanillaReg _ _) _ = LT-   compare _ (VanillaReg _ _) = GT-   compare (FloatReg _) _     = LT-   compare _ (FloatReg _)     = GT-   compare (DoubleReg _) _    = LT-   compare _ (DoubleReg _)    = GT-   compare (LongReg _) _      = LT-   compare _ (LongReg _)      = GT-   compare (XmmReg _) _       = LT-   compare _ (XmmReg _)       = GT-   compare (YmmReg _) _       = LT-   compare _ (YmmReg _)       = GT-   compare (ZmmReg _) _       = LT-   compare _ (ZmmReg _)       = GT-   compare Sp _ = LT-   compare _ Sp = GT-   compare SpLim _ = LT-   compare _ SpLim = GT-   compare Hp _ = LT-   compare _ Hp = GT-   compare HpLim _ = LT-   compare _ HpLim = GT-   compare CCCS _ = LT-   compare _ CCCS = GT-   compare CurrentTSO _ = LT-   compare _ CurrentTSO = GT-   compare CurrentNursery _ = LT-   compare _ CurrentNursery = GT-   compare HpAlloc _ = LT-   compare _ HpAlloc = GT-   compare GCEnter1 _ = LT-   compare _ GCEnter1 = GT-   compare GCFun _ = LT-   compare _ GCFun = GT-   compare BaseReg _ = LT-   compare _ BaseReg = GT-   compare MachSp _ = LT-   compare _ MachSp = GT-   compare UnwindReturnReg _ = LT-   compare _ UnwindReturnReg = GT-   compare EagerBlackholeInfo _ = LT-   compare _ EagerBlackholeInfo = GT---- convenient aliases-baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,-  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg-baseReg = CmmGlobal BaseReg-spReg = CmmGlobal Sp-hpReg = CmmGlobal Hp-hpLimReg = CmmGlobal HpLim-spLimReg = CmmGlobal SpLim-nodeReg = CmmGlobal node-currentTSOReg = CmmGlobal CurrentTSO-currentNurseryReg = CmmGlobal CurrentNursery-hpAllocReg = CmmGlobal HpAlloc-cccsReg = CmmGlobal CCCS--node :: GlobalReg-node = VanillaReg 1 VGcPtr--globalRegType :: DynFlags -> GlobalReg -> CmmType-globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags-globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags-globalRegType _      (FloatReg _)      = cmmFloat W32-globalRegType _      (DoubleReg _)     = cmmFloat W64-globalRegType _      (LongReg _)       = cmmBits W64--- TODO: improve the internal model of SIMD/vectorized registers--- the right design SHOULd improve handling of float and double code too.--- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim-globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)-globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)-globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)--globalRegType dflags Hp                = gcWord dflags-                                            -- The initialiser for all-                                            -- dynamically allocated closures-globalRegType dflags _                 = bWord dflags--isArgReg :: GlobalReg -> Bool-isArgReg (VanillaReg {}) = True-isArgReg (FloatReg {})   = True-isArgReg (DoubleReg {})  = True-isArgReg (LongReg {})    = True-isArgReg (XmmReg {})     = True-isArgReg (YmmReg {})     = True-isArgReg (ZmmReg {})     = True-isArgReg _               = False
− compiler/cmm/CmmImplementSwitchPlans.hs 
@@ -1,116 +0,0 @@-{-# LANGUAGE GADTs #-}-module CmmImplementSwitchPlans-  ( cmmImplementSwitchPlans-  )-where--import GhcPrelude--import Hoopl.Block-import BlockId-import Cmm-import CmmUtils-import CmmSwitch-import UniqSupply-import DynFlags------- This module replaces Switch statements as generated by the Stg -> Cmm--- transformation, which might be huge and sparse and hence unsuitable for--- assembly code, by proper constructs (if-then-else trees, dense jump tables).------ The actual, abstract strategy is determined by createSwitchPlan in--- CmmSwitch and returned as a SwitchPlan; here is just the implementation in--- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.------ This division into different modules is both to clearly separate concerns,--- but also because createSwitchPlan needs access to the constructors of--- SwitchTargets, a data type exported abstractly by CmmSwitch.------- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for--- code generation.-cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph-cmmImplementSwitchPlans dflags g-    -- Switch generation done by backend (LLVM/C)-    | targetSupportsSwitch (hscTarget dflags) = return g-    | otherwise = do-    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)-    return $ ofBlockList (g_entry g) blocks'--visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]-visitSwitches dflags block-  | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block-  = do-    let plan = createSwitchPlan ids-    -- See Note [Floating switch expressions]-    (assignSimple, simpleExpr) <- floatSwitchExpr dflags vanillaExpr--    (newTail, newBlocks) <- implementSwitchPlan dflags scope simpleExpr plan--    let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail--    return $ block' : newBlocks--  | otherwise-  = return [block]---- Note [Floating switch expressions]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- When we translate a sparse switch into a search tree we would like--- to compute the value we compare against only once.---- For this purpose we assign the switch expression to a local register--- and then use this register when constructing the actual binary tree.---- This is important as the expression could contain expensive code like--- memory loads or divisions which we REALLY don't want to duplicate.---- This happened in parts of the handwritten RTS Cmm code. See also #16933---- See Note [Floating switch expressions]-floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)-floatSwitchExpr _      reg@(CmmReg {})  = return (emptyBlock, reg)-floatSwitchExpr dflags expr             = do-  (assign, expr') <- cmmMkAssign dflags expr <$> getUniqueM-  return (BMiddle assign, expr')----- Implementing a switch plan (returning a tail block)-implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])-implementSwitchPlan dflags scope expr = go-  where-    go (Unconditionally l)-      = return (emptyBlock `blockJoinTail` CmmBranch l, [])-    go (JumpTable ids)-      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])-    go (IfLT signed i ids1 ids2)-      = do-        (bid1, newBlocks1) <- go' ids1-        (bid2, newBlocks2) <- go' ids2--        let lt | signed    = cmmSLtWord-               | otherwise = cmmULtWord-            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i-            lastNode = CmmCondBranch scrut bid1 bid2 Nothing-            lastBlock = emptyBlock `blockJoinTail` lastNode-        return (lastBlock, newBlocks1++newBlocks2)-    go (IfEqual i l ids2)-      = do-        (bid2, newBlocks2) <- go' ids2--        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i-            lastNode = CmmCondBranch scrut bid2 l Nothing-            lastBlock = emptyBlock `blockJoinTail` lastNode-        return (lastBlock, newBlocks2)--    -- Same but returning a label to branch to-    go' (Unconditionally l)-      = return (l, [])-    go' p-      = do-        bid <- mkBlockId `fmap` getUniqueM-        (last, newBlocks) <- go p-        let block = CmmEntry bid scope `blockJoinHead` last-        return (bid, block: newBlocks)
− compiler/cmm/CmmInfo.hs 
@@ -1,593 +0,0 @@-{-# LANGUAGE CPP #-}-module CmmInfo (-  mkEmptyContInfoTable,-  cmmToRawCmm,-  mkInfoTable,-  srtEscape,--  -- info table accessors-  closureInfoPtr,-  entryCode,-  getConstrTag,-  cmmGetClosureType,-  infoTable,-  infoTableConstrTag,-  infoTableSrtBitmap,-  infoTableClosureType,-  infoTablePtrs,-  infoTableNonPtrs,-  funInfoTable,-  funInfoArity,--  -- info table sizes and offsets-  stdInfoTableSizeW,-  fixedInfoTableSizeW,-  profInfoTableSizeW,-  maxStdInfoTableSizeW,-  maxRetInfoTableSizeW,-  stdInfoTableSizeB,-  conInfoTableSizeB,-  stdSrtBitmapOffset,-  stdClosureTypeOffset,-  stdPtrsOffset, stdNonPtrsOffset,-) where--#include "HsVersions.h"--import GhcPrelude--import Cmm-import CmmUtils-import CLabel-import SMRep-import Bitmap-import Stream (Stream)-import qualified Stream-import Hoopl.Collections--import GHC.Platform-import Maybes-import DynFlags-import ErrUtils (withTimingSilent)-import Panic-import UniqSupply-import MonadUtils-import Util-import Outputable--import Data.ByteString (ByteString)-import Data.Bits---- When we split at proc points, we need an empty info table.-mkEmptyContInfoTable :: CLabel -> CmmInfoTable-mkEmptyContInfoTable info_lbl-  = CmmInfoTable { cit_lbl  = info_lbl-                 , cit_rep  = mkStackRep []-                 , cit_prof = NoProfilingInfo-                 , cit_srt  = Nothing-                 , cit_clo  = Nothing }--cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a-            -> IO (Stream IO RawCmmGroup a)-cmmToRawCmm dflags cmms-  = do { uniqs <- mkSplitUniqSupply 'i'-       ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])-             do_one uniqs cmm =-               -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTimingSilent dflags (text "Cmm -> Raw Cmm")-                                forceRes $-                 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of-                   (b,uniqs') -> return (uniqs',b)-       ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)-       }--    where forceRes (uniqs, rawcmms) =-            uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms---- Make a concrete info table, represented as a list of CmmStatic--- (it can't be simply a list of Word, because the SRT field is--- represented by a label+offset expression).------ With tablesNextToCode, the layout is---      <reversed variable part>---      <normal forward StgInfoTable, but without---              an entry point at the front>---      <code>------ Without tablesNextToCode, the layout of an info table is---      <entry label>---      <normal forward rest of StgInfoTable>---      <forward variable part>------      See includes/rts/storage/InfoTables.h------ For return-points these are as follows------ Tables next to code:------                      <srt slot>---                      <standard info table>---      ret-addr -->    <entry code (if any)>------ Not tables-next-to-code:------      ret-addr -->    <ptr to entry code>---                      <standard info table>---                      <srt slot>------  * The SRT slot is only there if there is SRT info to record--mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]-mkInfoTable _ (CmmData sec dat)-  = return [CmmData sec dat]--mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)-  ---  -- in the non-tables-next-to-code case, procs can have at most a-  -- single info table associated with the entry label of the proc.-  ---  | not (tablesNextToCode dflags)-  = case topInfoTable proc of   --  must be at most one-      -- no info table-      Nothing ->-         return [CmmProc mapEmpty entry_lbl live blocks]--      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do-        (top_decls, (std_info, extra_bits)) <--             mkInfoTableContents dflags info Nothing-        let-          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info-          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits-        ---        -- Separately emit info table (with the function entry-        -- point as first entry) and the entry code-        ---        return (top_decls ++-                [CmmProc mapEmpty entry_lbl live blocks,-                 mkRODataLits info_lbl-                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])--  ---  -- With tables-next-to-code, we can have many info tables,-  -- associated with some of the BlockIds of the proc.  For each info-  -- table we need to turn it into CmmStatics, and collect any new-  -- CmmDecls that arise from doing so.-  ---  | otherwise-  = do-    (top_declss, raw_infos) <--       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))-    return (concat top_declss ++-            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])--  where-   do_one_info (lbl,itbl) = do-     (top_decls, (std_info, extra_bits)) <--         mkInfoTableContents dflags itbl Nothing-     let-        info_lbl = cit_lbl itbl-        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info-        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits-     ---     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $-                              reverse rel_extra_bits ++ rel_std_info))--------------------------------------------------------type InfoTableContents = ( [CmmLit]          -- The standard part-                         , [CmmLit] )        -- The "extra bits"--- These Lits have *not* had mkRelativeTo applied to them--mkInfoTableContents :: DynFlags-                    -> CmmInfoTable-                    -> Maybe Int               -- Override default RTS type tag?-                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls-                               InfoTableContents)       -- Info tbl + extra bits--mkInfoTableContents dflags-                    info@(CmmInfoTable { cit_lbl  = info_lbl-                                       , cit_rep  = smrep-                                       , cit_prof = prof-                                       , cit_srt = srt })-                    mb_rts_tag-  | RTSRep rts_tag rep <- smrep-  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)-    -- Completely override the rts_tag that mkInfoTableContents would-    -- otherwise compute, with the rts_tag stored in the RTSRep-    -- (which in turn came from a handwritten .cmm file)--  | StackRep frame <- smrep-  = do { (prof_lits, prof_data) <- mkProfLits dflags prof-       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt-       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame-       ; let-             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit-             rts_tag | Just tag <- mb_rts_tag = tag-                     | null liveness_data     = rET_SMALL -- Fits in extra_bits-                     | otherwise              = rET_BIG   -- Does not; extra_bits is-                                                          -- a label-       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }--  | HeapRep _ ptrs nonptrs closure_type <- smrep-  = do { let layout  = packIntsCLit dflags ptrs nonptrs-       ; (prof_lits, prof_data) <- mkProfLits dflags prof-       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt-       ; (mb_srt_field, mb_layout, extra_bits, ct_data)-                                <- mk_pieces closure_type srt_label-       ; let std_info = mkStdInfoTable dflags prof_lits-                                       (mb_rts_tag   `orElse` rtsClosureType smrep)-                                       (mb_srt_field `orElse` srt_bitmap)-                                       (mb_layout    `orElse` layout)-       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }-  where-    mk_pieces :: ClosureTypeInfo -> [CmmLit]-              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this-                        , Maybe CmmLit  -- Override the layout field with this-                        , [CmmLit]           -- "Extra bits" for info table-                        , [RawCmmDecl])      -- Auxiliary data decls-    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor-      = do { (descr_lit, decl) <- newStringLit con_descr-           ; return ( Just (CmmInt (fromIntegral con_tag)-                                   (halfWordWidth dflags))-                    , Nothing, [descr_lit], [decl]) }--    mk_pieces Thunk srt_label-      = return (Nothing, Nothing, srt_label, [])--    mk_pieces (ThunkSelector offset) _no_srt-      = return (Just (CmmInt 0 (halfWordWidth dflags)),-                Just (mkWordCLit dflags (fromIntegral offset)), [], [])-         -- Layout known (one free var); we use the layout field for offset--    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label-      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label-           ; return (Nothing, Nothing,  extra_bits, []) }--    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label-      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits-           ; let fun_type | null liveness_data = aRG_GEN-                          | otherwise          = aRG_GEN_BIG-                 extra_bits = [ packIntsCLit dflags fun_type arity ]-                           ++ (if inlineSRT dflags then [] else [ srt_lit ])-                           ++ [ liveness_lit, slow_entry ]-           ; return (Nothing, Nothing, extra_bits, liveness_data) }-      where-        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)-        srt_lit = case srt_label of-                    []          -> mkIntCLit dflags 0-                    (lit:_rest) -> ASSERT( null _rest ) lit--    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)--mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier--packIntsCLit :: DynFlags -> Int -> Int -> CmmLit-packIntsCLit dflags a b = packHalfWordsCLit dflags-                           (toStgHalfWord dflags (fromIntegral a))-                           (toStgHalfWord dflags (fromIntegral b))---mkSRTLit :: DynFlags-         -> CLabel-         -> Maybe CLabel-         -> ([CmmLit],    -- srt_label, if any-             CmmLit)      -- srt_bitmap-mkSRTLit dflags info_lbl (Just lbl)-  | inlineSRT dflags-  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))-mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))-mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))----- | Is the SRT offset field inline in the info table on this platform?------ See the section "Referring to an SRT from the info table" in--- Note [SRTs] in CmmBuildInfoTables.hs-inlineSRT :: DynFlags -> Bool-inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64-  && tablesNextToCode dflags---------------------------------------------------------------------------------      Lay out the info table and handle relative offsets--------------------------------------------------------------------------------- This function takes---   * the standard info table portion (StgInfoTable)---   * the "extra bits" (StgFunInfoExtraRev etc.)---   * the entry label---   * the code--- and lays them out in memory, producing a list of RawCmmDecl---------------------------------------------------------------------------------      Position independent code-------------------------------------------------------------------------------- In order to support position independent code, we mustn't put absolute--- references into read-only space. Info tables in the tablesNextToCode--- case must be in .text, which is read-only, so we doctor the CmmLits--- to use relative offsets instead.---- Note that this is done even when the -fPIC flag is not specified,--- as we want to keep binary compatibility between PIC and non-PIC.--makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit--makeRelativeRefTo dflags info_lbl (CmmLabel lbl)-  | tablesNextToCode dflags-  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)-makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)-  | tablesNextToCode dflags-  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)-makeRelativeRefTo _ _ lit = lit----------------------------------------------------------------------------------              Build a liveness mask for the stack layout--------------------------------------------------------------------------------- There are four kinds of things on the stack:------      - pointer variables (bound in the environment)---      - non-pointer variables (bound in the environment)---      - free slots (recorded in the stack free list)---      - non-pointer data slots (recorded in the stack free list)------ The first two are represented with a 'Just' of a 'LocalReg'.--- The last two with one or more 'Nothing' constructors.--- Each 'Nothing' represents one used word.------ The head of the stack layout is the top of the stack and--- the least-significant bit.--mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])-              -- ^ Returns:-              --   1. The bitmap (literal value or label)-              --   2. Large bitmap CmmData if needed--mkLivenessBits dflags liveness-  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word-  = do { uniq <- getUniqueM-       ; let bitmap_lbl = mkBitmapLabel uniq-       ; return (CmmLabel bitmap_lbl,-                 [mkRODataLits bitmap_lbl lits]) }--  | otherwise -- Fits in one word-  = return (mkStgWordCLit dflags bitmap_word, [])-  where-    n_bits = length liveness--    bitmap :: Bitmap-    bitmap = mkBitmap dflags liveness--    small_bitmap = case bitmap of-                     []  -> toStgWord dflags 0-                     [b] -> b-                     _   -> panic "mkLiveness"-    bitmap_word = toStgWord dflags (fromIntegral n_bits)-              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)--    lits = mkWordCLit dflags (fromIntegral n_bits)-         : map (mkStgWordCLit dflags) bitmap-      -- The first word is the size.  The structure must match-      -- StgLargeBitmap in includes/rts/storage/InfoTable.h---------------------------------------------------------------------------------      Generating a standard info table--------------------------------------------------------------------------------- The standard bits of an info table.  This part of the info table--- corresponds to the StgInfoTable type defined in--- includes/rts/storage/InfoTables.h.------ Its shape varies with ticky/profiling/tables next to code etc--- so we can't use constant offsets from Constants--mkStdInfoTable-   :: DynFlags-   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)-   -> Int               -- Closure RTS tag-   -> CmmLit            -- SRT length-   -> CmmLit            -- layout field-   -> [CmmLit]--mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit- =      -- Parallel revertible-black hole field-    prof_info-        -- Ticky info (none at present)-        -- Debug info (none at present)- ++ [layout_lit, tag, srt]-- where-    prof_info-        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]-        | otherwise = []--    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)---------------------------------------------------------------------------------      Making string literals-------------------------------------------------------------------------------mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])-mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])-mkProfLits _ (ProfilingInfo td cd)-  = do { (td_lit, td_decl) <- newStringLit td-       ; (cd_lit, cd_decl) <- newStringLit cd-       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }--newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)-newStringLit bytes-  = do { uniq <- getUniqueM-       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }----- Misc utils---- | Value of the srt field of an info table when using an StgLargeSRT-srtEscape :: DynFlags -> StgHalfWord-srtEscape dflags = toStgHalfWord dflags (-1)---------------------------------------------------------------------------------      Accessing fields of an info table--------------------------------------------------------------------------------- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is--- enabled.-wordAligned :: DynFlags -> CmmExpr -> CmmExpr-wordAligned dflags e-  | gopt Opt_AlignmentSanitisation dflags-  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]-  | otherwise-  = e--closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer and returns the info table pointer-closureInfoPtr dflags e =-    CmmLoad (wordAligned dflags e) (bWord dflags)--entryCode :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info pointer (the first word of a closure)--- and returns its entry code-entryCode dflags e- | tablesNextToCode dflags = e- | otherwise               = CmmLoad e (bWord dflags)--getConstrTag :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer, and return the *zero-indexed*--- constructor tag obtained from the info table--- This lives in the SRT field of the info table--- (constructors don't need SRTs).-getConstrTag dflags closure_ptr-  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]-  where-    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)--cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer, and return the closure type--- obtained from the info table-cmmGetClosureType dflags closure_ptr-  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]-  where-    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)--infoTable :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info pointer (the first word of a closure)--- and returns a pointer to the first word of the standard-form--- info table, excluding the entry-code word (if present)-infoTable dflags info_ptr-  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)-  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer--infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the constr tag--- field of the info table (same as the srt_bitmap field)-infoTableConstrTag = infoTableSrtBitmap--infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the srt_bitmap--- field of the info table-infoTableSrtBitmap dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)--infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the closure type--- field of the info table.-infoTableClosureType dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)--infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr-infoTablePtrs dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)--infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr-infoTableNonPtrs dflags info_tbl-  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)--funInfoTable :: DynFlags -> CmmExpr -> CmmExpr--- Takes the info pointer of a function,--- and returns a pointer to the first word of the StgFunInfoExtra struct--- in the info table.-funInfoTable dflags info_ptr-  | tablesNextToCode dflags-  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)-  | otherwise-  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)-                                -- Past the entry code pointer---- Takes the info pointer of a function, returns the function's arity-funInfoArity :: DynFlags -> CmmExpr -> CmmExpr-funInfoArity dflags iptr-  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))-  where-   fun_info = funInfoTable dflags iptr-   rep = cmmBits (widthFromBytes rep_bytes)--   (rep_bytes, offset)-    | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc-                                , oFFSET_StgFunInfoExtraRev_arity dflags )-    | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc-                                , oFFSET_StgFunInfoExtraFwd_arity dflags )--   pc = platformConstants dflags-------------------------------------------------------------------------------------      Info table sizes & offsets-----------------------------------------------------------------------------------stdInfoTableSizeW :: DynFlags -> WordOff--- The size of a standard info table varies with profiling/ticky etc,--- so we can't get it from Constants--- It must vary in sync with mkStdInfoTable-stdInfoTableSizeW dflags-  = fixedInfoTableSizeW-  + if gopt Opt_SccProfilingOn dflags-       then profInfoTableSizeW-       else 0--fixedInfoTableSizeW :: WordOff-fixedInfoTableSizeW = 2 -- layout, type--profInfoTableSizeW :: WordOff-profInfoTableSizeW = 2--maxStdInfoTableSizeW :: WordOff-maxStdInfoTableSizeW =-  1 {- entry, when !tablesNextToCode -}-  + fixedInfoTableSizeW-  + profInfoTableSizeW--maxRetInfoTableSizeW :: WordOff-maxRetInfoTableSizeW =-  maxStdInfoTableSizeW-  + 1 {- srt label -}--stdInfoTableSizeB  :: DynFlags -> ByteOff-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags--stdSrtBitmapOffset :: DynFlags -> ByteOff--- Byte offset of the SRT bitmap half-word which is--- in the *higher-addressed* part of the type_lit-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags--stdClosureTypeOffset :: DynFlags -> ByteOff--- Byte offset of the closure type half-word-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags--stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff-stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags--conInfoTableSizeB :: DynFlags -> Int-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
− compiler/cmm/CmmLayoutStack.hs 
@@ -1,1236 +0,0 @@-{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}-module CmmLayoutStack (-       cmmLayoutStack, setInfoTableStackMap-  ) where--import GhcPrelude hiding ((<*>))--import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation-import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation--import BasicTypes-import Cmm-import CmmInfo-import BlockId-import CLabel-import CmmUtils-import MkGraph-import ForeignCall-import CmmLive-import CmmProcPoint-import SMRep-import Hoopl.Block-import Hoopl.Collections-import Hoopl.Dataflow-import Hoopl.Graph-import Hoopl.Label-import UniqSupply-import Maybes-import UniqFM-import Util--import DynFlags-import FastString-import Outputable hiding ( isEmpty )-import qualified Data.Set as Set-import Control.Monad.Fix-import Data.Array as Array-import Data.Bits-import Data.List (nub)--{- Note [Stack Layout]--The job of this pass is to-- - replace references to abstract stack Areas with fixed offsets from Sp.-- - replace the CmmHighStackMark constant used in the stack check with-   the maximum stack usage of the proc.-- - save any variables that are live across a call, and reload them as-   necessary.--Before stack allocation, local variables remain live across native-calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local-variables are clobbered by native calls.--We want to do stack allocation so that as far as possible- - stack use is minimized, and- - unnecessary stack saves and loads are avoided.--The algorithm we use is a variant of linear-scan register allocation,-where the stack is our register file.--We proceed in two passes, see Note [Two pass approach] for why they are not easy-to merge into one.--Pass 1:-- - First, we do a liveness analysis, which annotates every block with-   the variables live on entry to the block.-- - We traverse blocks in reverse postorder DFS; that is, we visit at-   least one predecessor of a block before the block itself.  The-   stack layout flowing from the predecessor of the block will-   determine the stack layout on entry to the block.-- - We maintain a data structure--     Map Label StackMap--   which describes the contents of the stack and the stack pointer on-   entry to each block that is a successor of a block that we have-   visited.-- - For each block we visit:--    - Look up the StackMap for this block.--    - If this block is a proc point (or a call continuation, if we aren't-      splitting proc points), we need to reload all the live variables from the-      stack - but this is done in Pass 2, which calculates more precise liveness-      information (see description of Pass 2).--    - Walk forwards through the instructions:-      - At an assignment  x = Sp[loc]-        - Record the fact that Sp[loc] contains x, so that we won't-          need to save x if it ever needs to be spilled.-      - At an assignment  x = E-        - If x was previously on the stack, it isn't any more-      - At the last node, if it is a call or a jump to a proc point-        - Lay out the stack frame for the call (see setupStackFrame)-        - emit instructions to save all the live variables-        - Remember the StackMaps for all the successors-        - emit an instruction to adjust Sp-      - If the last node is a branch, then the current StackMap is the-        StackMap for the successors.--    - Manifest Sp: replace references to stack areas in this block-      with real Sp offsets. We cannot do this until we have laid out-      the stack area for the successors above.--      In this phase we also eliminate redundant stores to the stack;-      see elimStackStores.--  - There is one important gotcha: sometimes we'll encounter a control-    transfer to a block that we've already processed (a join point),-    and in that case we might need to rearrange the stack to match-    what the block is expecting. (exactly the same as in linear-scan-    register allocation, except here we have the luxury of an infinite-    supply of temporary variables).--  - Finally, we update the magic CmmHighStackMark constant with the-    stack usage of the function, and eliminate the whole stack check-    if there was no stack use. (in fact this is done as part of the-    main traversal, by feeding the high-water-mark output back in as-    an input. I hate cyclic programming, but it's just too convenient-    sometimes.)--  There are plenty of tricky details: update frames, proc points, return-  addresses, foreign calls, and some ad-hoc optimisations that are-  convenient to do here and effective in common cases.  Comments in the-  code below explain these.--Pass 2:--- Calculate live registers, but taking into account that nothing is live at the-  entry to a proc point.--- At each proc point and call continuation insert reloads of live registers from-  the stack (they were saved by Pass 1).---Note [Two pass approach]--The main reason for Pass 2 is being able to insert only the reloads that are-needed and the fact that the two passes need different liveness information.-Let's consider an example:--  .....-   \ /-    D   <- proc point-   / \-  E   F-   \ /-    G   <- proc point-    |-    X--Pass 1 needs liveness assuming that local variables are preserved across calls.-This is important because it needs to save any local registers to the stack-(e.g., if register a is used in block X, it must be saved before any native-call).-However, for Pass 2, where we want to reload registers from stack (in a proc-point), this is overly conservative and would lead us to generate reloads in D-for things used in X, even though we're going to generate reloads in G anyway-(since it's also a proc point).-So Pass 2 calculates liveness knowing that nothing is live at the entry to a-proc point. This means that in D we only need to reload things used in E or F.-This can be quite important, for an extreme example see testcase for #3294.--Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1-is a forward one. Furthermore, Pass 1 is creating code that uses local registers-(saving them before a call), which the liveness analysis for Pass 2 must see to-be correct.---}----- All stack locations are expressed as positive byte offsets from the--- "base", which is defined to be the address above the return address--- on the stack on entry to this CmmProc.------ Lower addresses have higher StackLocs.----type StackLoc = ByteOff--{-- A StackMap describes the stack at any given point.  At a continuation- it has a particular layout, like this:--         |             | <- base-         |-------------|-         |     ret0    | <- base + 8-         |-------------|-         .  upd frame  . <- base + sm_ret_off-         |-------------|-         |             |-         .    vars     .-         . (live/dead) .-         |             | <- base + sm_sp - sm_args-         |-------------|-         |    ret1     |-         .  ret vals   . <- base + sm_sp    (<--- Sp points here)-         |-------------|--Why do we include the final return address (ret0) in our stack map?  I-have absolutely no idea, but it seems to be done that way consistently-in the rest of the code generator, so I played along here. --SDM--Note that we will be constructing an info table for the continuation-(ret1), which needs to describe the stack down to, but not including,-the update frame (or ret0, if there is no update frame).--}--data StackMap = StackMap- {  sm_sp   :: StackLoc-       -- ^ the offset of Sp relative to the base on entry-       -- to this block.- ,  sm_args :: ByteOff-       -- ^ the number of bytes of arguments in the area for this block-       -- Defn: the offset of young(L) relative to the base is given by-       -- (sm_sp - sm_args) of the StackMap for block L.- ,  sm_ret_off :: ByteOff-       -- ^ Number of words of stack that we do not describe with an info-       -- table, because it contains an update frame.- ,  sm_regs :: UniqFM (LocalReg,StackLoc)-       -- ^ regs on the stack- }--instance Outputable StackMap where-  ppr StackMap{..} =-     text "Sp = " <> int sm_sp $$-     text "sm_args = " <> int sm_args $$-     text "sm_ret_off = " <> int sm_ret_off $$-     text "sm_regs = " <> pprUFM sm_regs ppr---cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph-               -> UniqSM (CmmGraph, LabelMap StackMap)-cmmLayoutStack dflags procpoints entry_args-               graph@(CmmGraph { g_entry = entry })-  = do-    -- We need liveness info. Dead assignments are removed later-    -- by the sinking pass.-    let liveness = cmmLocalLiveness dflags graph-        blocks = revPostorder graph--    (final_stackmaps, _final_high_sp, new_blocks) <--          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->-            layout dflags procpoints liveness entry entry_args-                   rec_stackmaps rec_high_sp blocks--    blocks_with_reloads <--        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks-    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads-    return (ofBlockList entry new_blocks', final_stackmaps)---- -------------------------------------------------------------------------------- Pass 1--- -------------------------------------------------------------------------------layout :: DynFlags-       -> LabelSet                      -- proc points-       -> LabelMap CmmLocalLive         -- liveness-       -> BlockId                       -- entry-       -> ByteOff                       -- stack args on entry--       -> LabelMap StackMap             -- [final] stack maps-       -> ByteOff                       -- [final] Sp high water mark--       -> [CmmBlock]                    -- [in] blocks--       -> UniqSM-          ( LabelMap StackMap           -- [out] stack maps-          , ByteOff                     -- [out] Sp high water mark-          , [CmmBlock]                  -- [out] new blocks-          )--layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks-  = go blocks init_stackmap entry_args []-  where-    (updfr, cont_info)  = collectContInfo blocks--    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args-                                               , sm_args = entry_args-                                               , sm_ret_off = updfr-                                               , sm_regs = emptyUFM-                                               }--    go [] acc_stackmaps acc_hwm acc_blocks-      = return (acc_stackmaps, acc_hwm, acc_blocks)--    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks-      = do-       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0--       let stack0@StackMap { sm_sp = sp0 }-               = mapFindWithDefault-                     (pprPanic "no stack map for" (ppr entry_lbl))-                     entry_lbl acc_stackmaps--       -- (a) Update the stack map to include the effects of-       --     assignments in this block-       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0--       -- (b) Look at the last node and if we are making a call or-       --     jumping to a proc point, we must save the live-       --     variables, adjust Sp, and construct the StackMaps for-       --     each of the successor blocks.  See handleLastNode for-       --     details.-       (middle1, sp_off, last1, fixup_blocks, out)-           <- handleLastNode dflags procpoints liveness cont_info-                             acc_stackmaps stack1 tscope middle0 last0--       -- (c) Manifest Sp: run over the nodes in the block and replace-       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.-       ---       -- our block:-       --    middle0          -- the original middle nodes-       --    middle1          -- live variable saves from handleLastNode-       --    Sp = Sp + sp_off -- Sp adjustment goes here-       --    last1            -- the last node-       ---       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1--       let final_blocks =-               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high-                          entry0 middle_pre sp_off last1 fixup_blocks--       let acc_stackmaps' = mapUnion acc_stackmaps out--           -- If this block jumps to the GC, then we do not take its-           -- stack usage into account for the high-water mark.-           -- Otherwise, if the only stack usage is in the stack-check-           -- failure block itself, we will do a redundant stack-           -- check.  The stack has a buffer designed to accommodate-           -- the largest amount of stack needed for calling the GC.-           ---           this_sp_hwm | isGcJump last0 = 0-                       | otherwise      = sp0 - sp_off--           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))--       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)----- --------------------------------------------------------------------------------- Not foolproof, but GCFun is the culprit we most want to catch-isGcJump :: CmmNode O C -> Bool-isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })-  = l == GCFun || l == GCEnter1-isGcJump _something_else = False---- --------------------------------------------------------------------------------- This doesn't seem right somehow.  We need to find out whether this--- proc will push some update frame material at some point, so that we--- can avoid using that area of the stack for spilling.  The--- updfr_space field of the CmmProc *should* tell us, but it doesn't--- (I think maybe it gets filled in later when we do proc-point--- splitting).------ So we'll just take the max of all the cml_ret_offs.  This could be--- unnecessarily pessimistic, but probably not in the code we--- generate.--collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)-collectContInfo blocks-  = (maximum ret_offs, mapFromList (catMaybes mb_argss))- where-  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks--  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)-  get_cont b =-     case lastNode b of-        CmmCall { cml_cont = Just l, .. }-           -> (Just (l, cml_ret_args), cml_ret_off)-        CmmForeignCall { .. }-           -> (Just (succ, ret_args), ret_off)-        _other -> (Nothing, 0)----- -------------------------------------------------------------------------------- Updating the StackMap from middle nodes---- Look for loads from stack slots, and update the StackMap.  This is--- purely for optimisation reasons, so that we can avoid saving a--- variable back to a different stack slot if it is already on the--- stack.------ This happens a lot: for example when function arguments are passed--- on the stack and need to be immediately saved across a call, we--- want to just leave them where they are on the stack.----procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap-procMiddle stackmaps node sm-  = case node of-     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)-       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }-        where loc = getStackLoc area off stackmaps-     CmmAssign (CmmLocal r) _other-       -> sm { sm_regs = delFromUFM (sm_regs sm) r }-     _other-       -> sm--getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc-getStackLoc Old       n _         = n-getStackLoc (Young l) n stackmaps =-  case mapLookup l stackmaps of-    Nothing -> pprPanic "getStackLoc" (ppr l)-    Just sm -> sm_sp sm - sm_args sm + n----- -------------------------------------------------------------------------------- Handling stack allocation for a last node---- We take a single last node and turn it into:------    C1 (some statements)---    Sp = Sp + N---    C2 (some more statements)---    call f()          -- the actual last node------ plus possibly some more blocks (we may have to add some fixup code--- between the last node and the continuation).------ C1: is the code for saving the variables across this last node onto--- the stack, if the continuation is a call or jumps to a proc point.------ C2: if the last node is a safe foreign call, we have to inject some--- extra code that goes *after* the Sp adjustment.--handleLastNode-   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff-   -> LabelMap StackMap -> StackMap -> CmmTickScope-   -> Block CmmNode O O-   -> CmmNode O C-   -> UniqSM-      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment-      , ByteOff            -- amount to adjust Sp-      , CmmNode O C        -- new last node-      , [CmmBlock]         -- new blocks-      , LabelMap StackMap  -- stackmaps for the continuations-      )--handleLastNode dflags procpoints liveness cont_info stackmaps-               stack0@StackMap { sm_sp = sp0 } tscp middle last- = case last of-    --  At each return / tail call,-    --  adjust Sp to point to the last argument pushed, which-    --  is cml_args, after popping any other junk from the stack.-    CmmCall{ cml_cont = Nothing, .. } -> do-      let sp_off = sp0 - cml_args-      return ([], sp_off, last, [], mapEmpty)--    --  At each CmmCall with a continuation:-    CmmCall{ cml_cont = Just cont_lbl, .. } ->-       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off--    CmmForeignCall{ succ = cont_lbl, .. } -> do-       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off-            -- one word of args: the return address--    CmmBranch {}     ->  handleBranches-    CmmCondBranch {} ->  handleBranches-    CmmSwitch {}     ->  handleBranches--  where-     -- Calls and ForeignCalls are handled the same way:-     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff-              -> ( [CmmNode O O]-                 , ByteOff-                 , CmmNode O C-                 , [CmmBlock]-                 , LabelMap StackMap-                 )-     lastCall lbl cml_args cml_ret_args cml_ret_off-      =  ( assignments-         , spOffsetForCall sp0 cont_stack cml_args-         , last-         , [] -- no new blocks-         , mapSingleton lbl cont_stack )-      where-         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off---     prepareStack lbl cml_ret_args cml_ret_off-       | Just cont_stack <- mapLookup lbl stackmaps-             -- If we have already seen this continuation before, then-             -- we just have to make the stack look the same:-       = (fixupStack stack0 cont_stack, cont_stack)-             -- Otherwise, we have to allocate the stack frame-       | otherwise-       = (save_assignments, new_cont_stack)-       where-        (new_cont_stack, save_assignments)-           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0---     -- For other last nodes (branches), if any of the targets is a-     -- proc point, we have to set up the stack to match what the proc-     -- point is expecting.-     ---     handleBranches :: UniqSM ( [CmmNode O O]-                                , ByteOff-                                , CmmNode O C-                                , [CmmBlock]-                                , LabelMap StackMap )--     handleBranches-         -- Note [diamond proc point]-       | Just l <- futureContinuation middle-       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]-       = do-         let cont_args = mapFindWithDefault 0 l cont_info-             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)-             out = mapFromList [ (l', cont_stack)-                               | l' <- successors last ]-         return ( assigs-                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)-                , last-                , []-                , out)--        | otherwise = do-          pps <- mapM handleBranch (successors last)-          let lbl_map :: LabelMap Label-              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]-              fix_lbl l = mapFindWithDefault l l lbl_map-          return ( []-                 , 0-                 , mapSuccessors fix_lbl last-                 , concat [ blk | (_,_,_,blk) <- pps ]-                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )--     -- For each successor of this block-     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])-     handleBranch l-        --   (a) if the successor already has a stackmap, we need to-        --       shuffle the current stack to make it look the same.-        --       We have to insert a new block to make this happen.-        | Just stack2 <- mapLookup l stackmaps-        = do-             let assigs = fixupStack stack0 stack2-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs-             return (l, tmp_lbl, stack2, block)--        --   (b) if the successor is a proc point, save everything-        --       on the stack.-        | l `setMember` procpoints-        = do-             let cont_args = mapFindWithDefault 0 l cont_info-                 (stack2, assigs) =-                      setupStackFrame dflags l liveness (sm_ret_off stack0)-                                                        cont_args stack0-             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs-             return (l, tmp_lbl, stack2, block)--        --   (c) otherwise, the current StackMap is the StackMap for-        --       the continuation.  But we must remember to remove any-        --       variables from the StackMap that are *not* live at-        --       the destination, because this StackMap might be used-        --       by fixupStack if this is a join point.-        | otherwise = return (l, l, stack1, [])-        where live = mapFindWithDefault (panic "handleBranch") l liveness-              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }-              is_live (r,_) = r `elemRegSet` live---makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap-               -> CmmTickScope -> [CmmNode O O]-               -> UniqSM (Label, [CmmBlock])-makeFixupBlock dflags sp0 l stack tscope assigs-  | null assigs && sp0 == sm_sp stack = return (l, [])-  | otherwise = do-    tmp_lbl <- newBlockId-    let sp_off = sp0 - sm_sp stack-        block = blockJoin (CmmEntry tmp_lbl tscope)-                          ( maybeAddSpAdj dflags sp0 sp_off-                           $ blockFromList assigs )-                          (CmmBranch l)-    return (tmp_lbl, [block])----- Sp is currently pointing to current_sp,--- we want it to point to---    (sm_sp cont_stack - sm_args cont_stack + args)--- so the difference is---    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)-spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff-spOffsetForCall current_sp cont_stack args-  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)----- | create a sequence of assignments to establish the new StackMap,--- given the old StackMap.-fixupStack :: StackMap -> StackMap -> [CmmNode O O]-fixupStack old_stack new_stack = concatMap move new_locs- where-     old_map  = sm_regs old_stack-     new_locs = stackSlotRegs new_stack--     move (r,n)-       | Just (_,m) <- lookupUFM old_map r, n == m = []-       | otherwise = [CmmStore (CmmStackSlot Old n)-                               (CmmReg (CmmLocal r))]----setupStackFrame-             :: DynFlags-             -> BlockId                 -- label of continuation-             -> LabelMap CmmLocalLive   -- liveness-             -> ByteOff      -- updfr-             -> ByteOff      -- bytes of return values on stack-             -> StackMap     -- current StackMap-             -> (StackMap, [CmmNode O O])--setupStackFrame dflags lbl liveness updfr_off ret_args stack0-  = (cont_stack, assignments)-  where-      -- get the set of LocalRegs live in the continuation-      live = mapFindWithDefault Set.empty lbl liveness--      -- the stack from the base to updfr_off is off-limits.-      -- our new stack frame contains:-      --   * saved live variables-      --   * the return address [young(C) + 8]-      --   * the args for the call,-      --     which are replaced by the return values at the return-      --     point.--      -- everything up to updfr_off is off-limits-      -- stack1 contains updfr_off, plus everything we need to save-      (stack1, assignments) = allocate dflags updfr_off live stack0--      -- And the Sp at the continuation is:-      --   sm_sp stack1 + ret_args-      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args-                         , sm_args = ret_args-                         , sm_ret_off = updfr_off-                         }----- -------------------------------------------------------------------------------- Note [diamond proc point]------ This special case looks for the pattern we get from a typical--- tagged case expression:------    Sp[young(L1)] = L1---    if (R1 & 7) != 0 goto L1 else goto L2---  L2:---    call [R1] returns to L1---  L1: live: {y}---    x = R1------ If we let the generic case handle this, we get------    Sp[-16] = L1---    if (R1 & 7) != 0 goto L1a else goto L2---  L2:---    Sp[-8] = y---    Sp = Sp - 16---    call [R1] returns to L1---  L1a:---    Sp[-8] = y---    Sp = Sp - 16---    goto L1---  L1:---    x = R1------ The code for saving the live vars is duplicated in each branch, and--- furthermore there is an extra jump in the fast path (assuming L1 is--- a proc point, which it probably is if there is a heap check).------ So to fix this we want to set up the stack frame before the--- conditional jump.  How do we know when to do this, and when it is--- safe?  The basic idea is, when we see the assignment------   Sp[young(L)] = L------ we know that---   * we are definitely heading for L---   * there can be no more reads from another stack area, because young(L)---     overlaps with it.------ We don't necessarily know that everything live at L is live now--- (some might be assigned between here and the jump to L).  So we--- simplify and only do the optimisation when we see------   (1) a block containing an assignment of a return address L---   (2) ending in a branch where one (and only) continuation goes to L,---       and no other continuations go to proc points.------ then we allocate the stack frame for L at the end of the block,--- before the branch.------ We could generalise (2), but that would make it a bit more--- complicated to handle, and this currently catches the common case.--futureContinuation :: Block CmmNode O O -> Maybe BlockId-futureContinuation middle = foldBlockNodesB f middle Nothing-   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId-         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _-               = Just l-         f _ r = r---- -------------------------------------------------------------------------------- Saving live registers---- | Given a set of live registers and a StackMap, save all the registers--- on the stack and return the new StackMap and the assignments to do--- the saving.----allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap-         -> (StackMap, [CmmNode O O])-allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0-                                              , sm_regs = regs0 }- =-   -- we only have to save regs that are not already in a slot-   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)-       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0-   in--   -- make a map of the stack-   let stack = reverse $ Array.elems $-               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $-                 ret_words ++ live_words-            where ret_words =-                   [ (x, Occupied)-                   | x <- [ 1 .. toWords dflags ret_off] ]-                  live_words =-                   [ (toWords dflags x, Occupied)-                   | (r,off) <- nonDetEltsUFM regs1,-                   -- See Note [Unique Determinism and code generation]-                     let w = localRegBytes dflags r,-                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]-   in--   -- Pass over the stack: find slots to save all the new live variables,-   -- choosing the oldest slots first (hence a foldr).-   let-       save slot ([], stack, n, assigs, regs) -- no more regs to save-          = ([], slot:stack, plusW dflags n 1, assigs, regs)-       save slot (to_save, stack, n, assigs, regs)-          = case slot of-               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)-               Empty-                 | Just (stack', r, to_save') <--                       select_save to_save (slot:stack)-                 -> let assig = CmmStore (CmmStackSlot Old n')-                                         (CmmReg (CmmLocal r))-                        n' = plusW dflags n 1-                   in-                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)--                 | otherwise-                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)--       -- we should do better here: right now we'll fit the smallest first,-       -- but it would make more sense to fit the biggest first.-       select_save :: [LocalReg] -> [StackSlot]-                   -> Maybe ([StackSlot], LocalReg, [LocalReg])-       select_save regs stack = go regs []-         where go []     _no_fit = Nothing-               go (r:rs) no_fit-                 | Just rest <- dropEmpty words stack-                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)-                 | otherwise-                 = go rs (r:no_fit)-                 where words = localRegWords dflags r--       -- fill in empty slots as much as possible-       (still_to_save, save_stack, n, save_assigs, save_regs)-          = foldr save (to_save, [], 0, [], []) stack--       -- push any remaining live vars on the stack-       (push_sp, push_assigs, push_regs)-          = foldr push (n, [], []) still_to_save-          where-              push r (n, assigs, regs)-                = (n', assig : assigs, (r,(r,n')) : regs)-                where-                  n' = n + localRegBytes dflags r-                  assig = CmmStore (CmmStackSlot Old n')-                                   (CmmReg (CmmLocal r))--       trim_sp-          | not (null push_regs) = push_sp-          | otherwise-          = plusW dflags n (- length (takeWhile isEmpty save_stack))--       final_regs = regs1 `addListToUFM` push_regs-                          `addListToUFM` save_regs--   in-  -- XXX should be an assert-   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else--   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else--   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }-   , push_assigs ++ save_assigs )----- -------------------------------------------------------------------------------- Manifesting Sp---- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The--- block looks like this:------    middle_pre       -- the middle nodes---    Sp = Sp + sp_off -- Sp adjustment goes here---    last             -- the last node------ And we have some extra blocks too (that don't contain Sp adjustments)------ The adjustment for middle_pre will be different from that for--- middle_post, because the Sp adjustment intervenes.----manifestSp-   :: DynFlags-   -> LabelMap StackMap  -- StackMaps for other blocks-   -> StackMap           -- StackMap for this block-   -> ByteOff            -- Sp on entry to the block-   -> ByteOff            -- SpHigh-   -> CmmNode C O        -- first node-   -> [CmmNode O O]      -- middle-   -> ByteOff            -- sp_off-   -> CmmNode O C        -- last node-   -> [CmmBlock]         -- new blocks-   -> [CmmBlock]         -- final blocks with Sp manifest--manifestSp dflags stackmaps stack0 sp0 sp_high-           first middle_pre sp_off last fixup_blocks-  = final_block : fixup_blocks'-  where-    area_off = getAreaOff stackmaps--    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x-    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)-    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)--    final_middle = maybeAddSpAdj dflags sp0 sp_off-                 . blockFromList-                 . map adj_pre_sp-                 . elimStackStores stack0 stackmaps area_off-                 $ middle_pre-    final_last    = optStackCheck (adj_post_sp last)--    final_block   = blockJoin first final_middle final_last--    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks--getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)-getAreaOff _ Old = 0-getAreaOff stackmaps (Young l) =-  case mapLookup l stackmaps of-    Just sm -> sm_sp sm - sm_args sm-    Nothing -> pprPanic "getAreaOff" (ppr l)---maybeAddSpAdj-  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O-maybeAddSpAdj dflags sp0 sp_off block =-  add_initial_unwind $ add_adj_unwind $ adj block-  where-    adj block-      | sp_off /= 0-      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)-      | otherwise = block-    -- Add unwind pseudo-instruction at the beginning of each block to-    -- document Sp level for debugging-    add_initial_unwind block-      | debugLevel dflags > 0-      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block-      | otherwise-      = block-      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)--    -- Add unwind pseudo-instruction right after the Sp adjustment-    -- if there is one.-    add_adj_unwind block-      | debugLevel dflags > 0-      , sp_off /= 0-      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]-      | otherwise-      = block-      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)--{- Note [SP old/young offsets]--Sp(L) is the Sp offset on entry to block L relative to the base of the-OLD area.--SpArgs(L) is the size of the young area for L, i.e. the number of-arguments.-- - in block L, each reference to [old + N] turns into-   [Sp + Sp(L) - N]-- - in block L, each reference to [young(L') + N] turns into-   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]-- - be careful with the last node of each block: Sp has already been adjusted-   to be Sp + Sp(L) - Sp(L')--}--areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr--areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)-  = cmmOffset dflags spExpr (sp_old - area_off area - n)-    -- Replace (CmmStackSlot area n) with an offset from Sp--areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)-  = mkIntExpr dflags sp_hwm-    -- Replace CmmHighStackMark with the number of bytes of stack used,-    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap--areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)-  | falseStackCheck args-  = zeroExpr dflags-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)-  | falseStackCheck args-  = mkIntExpr dflags 1-    -- Replace a stack-overflow test that cannot fail with a no-op-    -- See Note [Always false stack check]--areaToSp _ _ _ _ other = other---- | Determine whether a stack check cannot fail.-falseStackCheck :: [CmmExpr] -> Bool-falseStackCheck [ CmmMachOp (MO_Sub _)-                      [ CmmRegOff (CmmGlobal Sp) x_off-                      , CmmLit (CmmInt y_lit _)]-                , CmmReg (CmmGlobal SpLim)]-  = fromIntegral x_off >= y_lit-falseStackCheck _ = False---- Note [Always false stack check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- We can optimise stack checks of the form------   if ((Sp + x) - y < SpLim) then .. else ..------ where are non-negative integer byte offsets.  Since we know that--- SpLim <= Sp (remember the stack grows downwards), this test must--- yield False if (x >= y), so we can rewrite the comparison to False.--- A subsequent sinking pass will later drop the dead code.--- Optimising this away depends on knowing that SpLim <= Sp, so it is--- really the job of the stack layout algorithm, hence we do it now.------ The control flow optimiser may negate a conditional to increase--- the likelihood of a fallthrough if the branch is not taken.  But--- not every conditional is inverted as the control flow optimiser--- places some requirements on the predecessors of both branch targets.--- So we better look for the inverted comparison too.--optStackCheck :: CmmNode O C -> CmmNode O C-optStackCheck n = -- Note [Always false stack check]- case n of-   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false-   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true-   other -> other----- --------------------------------------------------------------------------------- | Eliminate stores of the form------    Sp[area+n] = r------ when we know that r is already in the same slot as Sp[area+n].  We--- could do this in a later optimisation pass, but that would involve--- a separate analysis and we already have the information to hand--- here.  It helps clean up some extra stack stores in common cases.------ Note that we may have to modify the StackMap as we walk through the--- code using procMiddle, since an assignment to a variable in the--- StackMap will invalidate its mapping there.----elimStackStores :: StackMap-                -> LabelMap StackMap-                -> (Area -> ByteOff)-                -> [CmmNode O O]-                -> [CmmNode O O]-elimStackStores stackmap stackmaps area_off nodes-  = go stackmap nodes-  where-    go _stackmap [] = []-    go stackmap (n:ns)-     = case n of-         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))-            | Just (_,off) <- lookupUFM (sm_regs stackmap) r-            , area_off area + m == off-            -> go stackmap ns-         _otherwise-            -> n : go (procMiddle stackmaps n stackmap) ns----- -------------------------------------------------------------------------------- Update info tables to include stack liveness---setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl-setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)-  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g-  where-    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =-       info_tbl { cit_rep = StackRep (get_liveness lbl) }-    fix_info _ other = other--    get_liveness :: BlockId -> Liveness-    get_liveness lbl-      = case mapLookup lbl stackmaps of-          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)-          Just sm -> stackMapToLiveness dflags sm--setInfoTableStackMap _ _ d = d---stackMapToLiveness :: DynFlags -> StackMap -> Liveness-stackMapToLiveness dflags StackMap{..} =-   reverse $ Array.elems $-        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,-                                     toWords dflags (sm_sp - sm_args)) live_words-   where-     live_words =  [ (toWords dflags off, False)-                   | (r,off) <- nonDetEltsUFM sm_regs-                   , isGcPtrType (localRegType r) ]-                   -- See Note [Unique Determinism and code generation]---- -------------------------------------------------------------------------------- Pass 2--- -------------------------------------------------------------------------------insertReloadsAsNeeded-    :: DynFlags-    -> ProcPointSet-    -> LabelMap StackMap-    -> BlockId-    -> [CmmBlock]-    -> UniqSM [CmmBlock]-insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do-    toBlockList . fst <$>-        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty-  where-    rewriteCC :: RewriteFun CmmLocalLive-    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do-        let entry_label = entryLabel e_node-            stackmap = case mapLookup entry_label final_stackmaps of-                Just sm -> sm-                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"--            -- Merge the liveness from successor blocks and analyse the last-            -- node.-            joined = gen_kill dflags x_node $!-                         joinOutFacts liveLattice x_node fact_base0-            -- What is live at the start of middle0.-            live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined--            -- If this is a procpoint we need to add the reloads, but only if-            -- they're actually live. Furthermore, nothing is live at the entry-            -- to a proc point.-            (middle1, live_with_reloads)-                | entry_label `setMember` procpoints-                = let reloads = insertReloads dflags stackmap live_at_middle0-                  in (foldr blockCons middle0 reloads, emptyRegSet)-                | otherwise-                = (middle0, live_at_middle0)--            -- Final liveness for this block.-            !fact_base2 = mapSingleton entry_label live_with_reloads--        return (BlockCC e_node middle1 x_node, fact_base2)--insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]-insertReloads dflags stackmap live =-     [ CmmAssign (CmmLocal reg)-                 -- This cmmOffset basically corresponds to manifesting-                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]-                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))-                          (localRegType reg))-     | (reg, reg_off) <- stackSlotRegs stackmap-     , reg `elemRegSet` live-     ]-   where-     sp_off = sm_sp stackmap---- -------------------------------------------------------------------------------- Lowering safe foreign calls--{--Note [Lower safe foreign calls]--We start with--   Sp[young(L1)] = L1- ,------------------------ | r1 = foo(x,y,z) returns to L1- '------------------------ L1:-   R1 = r1 -- copyIn, inserted by mkSafeCall-   ...--the stack layout algorithm will arrange to save and reload everything-live across the call.  Our job now is to expand the call so we get--   Sp[young(L1)] = L1- ,------------------------ | SAVE_THREAD_STATE()- | token = suspendThread(BaseReg, interruptible)- | r = foo(x,y,z)- | BaseReg = resumeThread(token)- | LOAD_THREAD_STATE()- | R1 = r  -- copyOut- | jump Sp[0]- '------------------------ L1:-   r = R1 -- copyIn, inserted by mkSafeCall-   ...--Note the copyOut, which saves the results in the places that L1 is-expecting them (see Note [safe foreign call convention]). Note also-that safe foreign call is replace by an unsafe one in the Cmm graph.--}--lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock-lowerSafeForeignCall dflags block-  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block-  = do-    -- Both 'id' and 'new_base' are KindNonPtr because they're-    -- RTS-only objects and are not subject to garbage collection-    id <- newTemp (bWord dflags)-    new_base <- newTemp (cmmRegType dflags baseReg)-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags-    save_state_code <- saveThreadState dflags-    load_state_code <- loadThreadState dflags-    let suspend = save_state_code  <*>-                  caller_save <*>-                  mkMiddle (callSuspendThread dflags id intrbl)-        midCall = mkUnsafeCall tgt res args-        resume  = mkMiddle (callResumeThread new_base id) <*>-                  -- Assign the result to BaseReg: we-                  -- might now have a different Capability!-                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>-                  caller_load <*>-                  load_state_code--        (_, regs, copyout) =-             copyOutOflow dflags NativeReturn Jump (Young succ)-                            (map (CmmReg . CmmLocal) res)-                            ret_off []--        -- NB. after resumeThread returns, the top-of-stack probably contains-        -- the stack frame for succ, but it might not: if the current thread-        -- received an exception during the call, then the stack might be-        -- different.  Hence we continue by jumping to the top stack frame,-        -- not by jumping to succ.-        jump = CmmCall { cml_target    = entryCode dflags $-                                         CmmLoad spExpr (bWord dflags)-                       , cml_cont      = Just succ-                       , cml_args_regs = regs-                       , cml_args      = widthInBytes (wordWidth dflags)-                       , cml_ret_args  = ret_args-                       , cml_ret_off   = ret_off }--    graph' <- lgraphOfAGraph ( suspend <*>-                               midCall <*>-                               resume  <*>-                               copyout <*>-                               mkLast jump, tscp)--    case toBlockList graph' of-      [one] -> let (_, middle', last) = blockSplit one-               in return (blockJoin entry (middle `blockAppend` middle') last)-      _ -> panic "lowerSafeForeignCall0"--  -- Block doesn't end in a safe foreign call:-  | otherwise = return block---foreignLbl :: FastString -> CmmExpr-foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))--callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O-callSuspendThread dflags id intrbl =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "suspendThread"))-        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))-       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]--callResumeThread :: LocalReg -> LocalReg -> CmmNode O O-callResumeThread new_base id =-  CmmUnsafeForeignCall-       (ForeignTarget (foreignLbl (fsLit "resumeThread"))-            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))-       [new_base] [CmmReg (CmmLocal id)]---- -------------------------------------------------------------------------------plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff-plusW dflags b w = b + w * wORD_SIZE dflags--data StackSlot = Occupied | Empty-     -- Occupied: a return address or part of an update frame--instance Outputable StackSlot where-  ppr Occupied = text "XXX"-  ppr Empty    = text "---"--dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]-dropEmpty 0 ss           = Just ss-dropEmpty n (Empty : ss) = dropEmpty (n-1) ss-dropEmpty _ _            = Nothing--isEmpty :: StackSlot -> Bool-isEmpty Empty = True-isEmpty _ = False--localRegBytes :: DynFlags -> LocalReg -> ByteOff-localRegBytes dflags r-    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))--localRegWords :: DynFlags -> LocalReg -> WordOff-localRegWords dflags = toWords dflags . localRegBytes dflags--toWords :: DynFlags -> ByteOff -> WordOff-toWords dflags x = x `quot` wORD_SIZE dflags---stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]-stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)-  -- See Note [Unique Determinism and code generation]
− compiler/cmm/CmmLex.x 
@@ -1,368 +0,0 @@------------------------------------------------------------------------------------ (c) The University of Glasgow, 2004-2006------ Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there--- are a few minor differences:------   * extra keywords for our macros, and float32/float64 types---   * global registers (Sp,Hp, etc.)-----------------------------------------------------------------------------------{-module CmmLex (-   CmmToken(..), cmmlex,-  ) where--import GhcPrelude--import CmmExpr--import Lexer-import CmmMonad-import SrcLoc-import UniqFM-import StringBuffer-import FastString-import Ctype-import Util---import TRACE--import Data.Word-import Data.Char-}--$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space-$white_no_nl = $whitechar # \n--$ascdigit  = 0-9-$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.-$digit     = [$ascdigit $unidigit]-$octit     = 0-7-$hexit     = [$digit A-F a-f]--$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.-$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]-$large     = [$asclarge $unilarge]--$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.-$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]-$small     = [$ascsmall $unismall \_]--$namebegin = [$large $small \. \$ \@]-$namechar  = [$namebegin $digit]--@decimal     = $digit+-@octal       = $octit+-@hexadecimal = $hexit+-@exponent    = [eE] [\-\+]? @decimal--@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent--@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})-@strchar     = ($printable # [\"\\]) | @escape--cmm :---$white_no_nl+           ;-^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output--^\# (line)?             { begin line_prag }---- single-line line pragmas, of the form---    # <line> "<file>" <extra-stuff> \n-<line_prag> $digit+                     { setLine line_prag1 }-<line_prag1> \" [^\"]* \"       { setFile line_prag2 }-<line_prag2> .*                         { pop }--<0> {-  \n                    ;--  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }--  ".."                  { kw CmmT_DotDot }-  "::"                  { kw CmmT_DoubleColon }-  ">>"                  { kw CmmT_Shr }-  "<<"                  { kw CmmT_Shl }-  ">="                  { kw CmmT_Ge }-  "<="                  { kw CmmT_Le }-  "=="                  { kw CmmT_Eq }-  "!="                  { kw CmmT_Ne }-  "&&"                  { kw CmmT_BoolAnd }-  "||"                  { kw CmmT_BoolOr }--  "True"                { kw CmmT_True  }-  "False"               { kw CmmT_False }-  "likely"              { kw CmmT_likely}--  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }-  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }-  F@decimal             { global_regN FloatReg }-  D@decimal             { global_regN DoubleReg }-  L@decimal             { global_regN LongReg }-  Sp                    { global_reg Sp }-  SpLim                 { global_reg SpLim }-  Hp                    { global_reg Hp }-  HpLim                 { global_reg HpLim }-  CCCS                  { global_reg CCCS }-  CurrentTSO            { global_reg CurrentTSO }-  CurrentNursery        { global_reg CurrentNursery }-  HpAlloc               { global_reg HpAlloc }-  BaseReg               { global_reg BaseReg }-  MachSp                { global_reg MachSp }-  UnwindReturnReg       { global_reg UnwindReturnReg }--  $namebegin $namechar* { name }--  0 @octal              { tok_octal }-  @decimal              { tok_decimal }-  0[xX] @hexadecimal    { tok_hexadecimal }-  @floating_point       { strtoken tok_float }--  \" @strchar* \"       { strtoken tok_string }-}--{-data CmmToken-  = CmmT_SpecChar  Char-  | CmmT_DotDot-  | CmmT_DoubleColon-  | CmmT_Shr-  | CmmT_Shl-  | CmmT_Ge-  | CmmT_Le-  | CmmT_Eq-  | CmmT_Ne-  | CmmT_BoolAnd-  | CmmT_BoolOr-  | CmmT_CLOSURE-  | CmmT_INFO_TABLE-  | CmmT_INFO_TABLE_RET-  | CmmT_INFO_TABLE_FUN-  | CmmT_INFO_TABLE_CONSTR-  | CmmT_INFO_TABLE_SELECTOR-  | CmmT_else-  | CmmT_export-  | CmmT_section-  | CmmT_goto-  | CmmT_if-  | CmmT_call-  | CmmT_jump-  | CmmT_foreign-  | CmmT_never-  | CmmT_prim-  | CmmT_reserve-  | CmmT_return-  | CmmT_returns-  | CmmT_import-  | CmmT_switch-  | CmmT_case-  | CmmT_default-  | CmmT_push-  | CmmT_unwind-  | CmmT_bits8-  | CmmT_bits16-  | CmmT_bits32-  | CmmT_bits64-  | CmmT_bits128-  | CmmT_bits256-  | CmmT_bits512-  | CmmT_float32-  | CmmT_float64-  | CmmT_gcptr-  | CmmT_GlobalReg GlobalReg-  | CmmT_Name      FastString-  | CmmT_String    String-  | CmmT_Int       Integer-  | CmmT_Float     Rational-  | CmmT_EOF-  | CmmT_False-  | CmmT_True-  | CmmT_likely-  deriving (Show)---- -------------------------------------------------------------------------------- Lexer actions--type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)--begin :: Int -> Action-begin code _span _str _len = do liftP (pushLexState code); lexToken--pop :: Action-pop _span _buf _len = liftP popLexState >> lexToken--special_char :: Action-special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))--kw :: CmmToken -> Action-kw tok span _buf _len = return (L span tok)--global_regN :: (Int -> GlobalReg) -> Action-global_regN con span buf len-  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))-  where buf' = stepOn buf-        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit--global_reg :: GlobalReg -> Action-global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))--strtoken :: (String -> CmmToken) -> Action-strtoken f span buf len =-  return (L span $! (f $! lexemeToString buf len))--name :: Action-name span buf len =-  case lookupUFM reservedWordsFM fs of-        Just tok -> return (L span tok)-        Nothing  -> return (L span (CmmT_Name fs))-  where-        fs = lexemeToFastString buf len--reservedWordsFM = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "CLOSURE",            CmmT_CLOSURE ),-        ( "INFO_TABLE",         CmmT_INFO_TABLE ),-        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),-        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),-        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),-        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),-        ( "else",               CmmT_else ),-        ( "export",             CmmT_export ),-        ( "section",            CmmT_section ),-        ( "goto",               CmmT_goto ),-        ( "if",                 CmmT_if ),-        ( "call",               CmmT_call ),-        ( "jump",               CmmT_jump ),-        ( "foreign",            CmmT_foreign ),-        ( "never",              CmmT_never ),-        ( "prim",               CmmT_prim ),-        ( "reserve",            CmmT_reserve ),-        ( "return",             CmmT_return ),-        ( "returns",            CmmT_returns ),-        ( "import",             CmmT_import ),-        ( "switch",             CmmT_switch ),-        ( "case",               CmmT_case ),-        ( "default",            CmmT_default ),-        ( "push",               CmmT_push ),-        ( "unwind",             CmmT_unwind ),-        ( "bits8",              CmmT_bits8 ),-        ( "bits16",             CmmT_bits16 ),-        ( "bits32",             CmmT_bits32 ),-        ( "bits64",             CmmT_bits64 ),-        ( "bits128",            CmmT_bits128 ),-        ( "bits256",            CmmT_bits256 ),-        ( "bits512",            CmmT_bits512 ),-        ( "float32",            CmmT_float32 ),-        ( "float64",            CmmT_float64 ),--- New forms-        ( "b8",                 CmmT_bits8 ),-        ( "b16",                CmmT_bits16 ),-        ( "b32",                CmmT_bits32 ),-        ( "b64",                CmmT_bits64 ),-        ( "b128",               CmmT_bits128 ),-        ( "b256",               CmmT_bits256 ),-        ( "b512",               CmmT_bits512 ),-        ( "f32",                CmmT_float32 ),-        ( "f64",                CmmT_float64 ),-        ( "gcptr",              CmmT_gcptr ),-        ( "likely",             CmmT_likely),-        ( "True",               CmmT_True  ),-        ( "False",              CmmT_False )-        ]--tok_decimal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))--tok_octal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))--tok_hexadecimal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))--tok_float str = CmmT_Float $! readRational str--tok_string str = CmmT_String (read str)-                 -- urk, not quite right, but it'll do for now---- -------------------------------------------------------------------------------- Line pragmas--setLine :: Int -> Action-setLine code span buf len = do-  let line = parseUnsignedInteger buf len 10 octDecDigit-  liftP $ do-    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)-          -- subtract one: the line number refers to the *following* line-    -- trace ("setLine "  ++ show line) $ do-    popLexState >> pushLexState code-  lexToken--setFile :: Int -> Action-setFile code span buf len = do-  let file = lexemeToFastString (stepOn buf) (len-2)-  liftP $ do-    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))-    popLexState >> pushLexState code-  lexToken---- -------------------------------------------------------------------------------- This is the top-level function: called from the parser each time a--- new token is to be read from the input.--cmmlex :: (Located CmmToken -> PD a) -> PD a-cmmlex cont = do-  (L span tok) <- lexToken-  --trace ("token: " ++ show tok) $ do-  cont (L (RealSrcSpan span) tok)--lexToken :: PD (RealLocated CmmToken)-lexToken = do-  inp@(loc1,buf) <- getInput-  sc <- liftP getLexState-  case alexScan inp sc of-    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1-                  liftP (setLastToken span 0)-                  return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"-    AlexSkip inp2 _ -> do-        setInput inp2-        lexToken-    AlexToken inp2@(end,_buf2) len t -> do-        setInput inp2-        let span = mkRealSrcSpan loc1 end-        span `seq` liftP (setLastToken span len)-        t span buf len---- -------------------------------------------------------------------------------- Monad stuff---- Stuff that Alex needs to know about our input type:-type AlexInput = (RealSrcLoc,StringBuffer)--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (_,s) = prevChar s '\n'---- backwards compatibility for Alex 2.x-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar inp = case alexGetByte inp of-                    Nothing    -> Nothing-                    Just (b,i) -> c `seq` Just (c,i)-                       where c = chr $ fromIntegral b--alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)-alexGetByte (loc,s)-  | atEnd s   = Nothing-  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))-  where c    = currentChar s-        b    = fromIntegral $ ord $ c-        loc' = advanceSrcLoc loc c-        s'   = stepOn s--getInput :: PD AlexInput-getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)--setInput :: AlexInput -> PD ()-setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()-}
− compiler/cmm/CmmLint.hs 
@@ -1,261 +0,0 @@------------------------------------------------------------------------------------ (c) The University of Glasgow 2011------ CmmLint: checking the correctness of Cmm statements and expressions----------------------------------------------------------------------------------{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-module CmmLint (-    cmmLint, cmmLintGraph-  ) where--import GhcPrelude--import Hoopl.Block-import Hoopl.Collections-import Hoopl.Graph-import Hoopl.Label-import Cmm-import CmmUtils-import CmmLive-import CmmSwitch (switchTargetsToList)-import PprCmm () -- For Outputable instances-import Outputable-import DynFlags--import Control.Monad (ap)---- Things to check:---     - invariant on CmmBlock in CmmExpr (see comment there)---     - check for branches to blocks that don't exist---     - check types---- -------------------------------------------------------------------------------- Exported entry points:--cmmLint :: (Outputable d, Outputable h)-        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc-cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops--cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc-cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g--runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc-runCmmLint dflags l p =-   case unCL (l p) dflags of-     Left err -> Just (vcat [text "Cmm lint error:",-                             nest 2 err,-                             text "Program was:",-                             nest 2 (ppr p)])-     Right _  -> Nothing--lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()-lintCmmDecl dflags (CmmProc _ lbl _ g)-  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g-lintCmmDecl _ (CmmData {})-  = return ()---lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()-lintCmmGraph dflags g =-    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks-    -- cmmLiveness throws an error if there are registers-    -- live on entry to the graph (i.e. undefined-    -- variables)-  where-       blocks = toBlockList g-       labels = setFromList (map entryLabel blocks)---lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()-lintCmmBlock labels block-  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do-        let (_, middle, last) = blockSplit block-        mapM_ lintCmmMiddle (blockToList middle)-        lintCmmLast labels last---- -------------------------------------------------------------------------------- lintCmmExpr---- Checks whether a CmmExpr is "type-correct", and check for obvious-looking--- byte/word mismatches.--lintCmmExpr :: CmmExpr -> CmmLint CmmType-lintCmmExpr (CmmLoad expr rep) = do-  _ <- lintCmmExpr expr-  -- Disabled, if we have the inlining phase before the lint phase,-  -- we can have funny offsets due to pointer tagging. -- EZY-  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $-  --   cmmCheckWordAddress expr-  return rep-lintCmmExpr expr@(CmmMachOp op args) = do-  dflags <- getDynFlags-  tys <- mapM lintCmmExpr args-  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op-        then cmmCheckMachOp op args tys-        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)-lintCmmExpr (CmmRegOff reg offset)-  = do dflags <- getDynFlags-       let rep = typeWidth (cmmRegType dflags reg)-       lintCmmExpr (CmmMachOp (MO_Add rep)-                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])-lintCmmExpr expr =-  do dflags <- getDynFlags-     return (cmmExprType dflags expr)---- Check for some common byte/word mismatches (eg. Sp + 1)-cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType-cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys-  = cmmCheckMachOp op [reg, lit] tys-cmmCheckMachOp op _ tys-  = do dflags <- getDynFlags-       return (machOpResultType dflags op tys)--{--isOffsetOp :: MachOp -> Bool-isOffsetOp (MO_Add _) = True-isOffsetOp (MO_Sub _) = True-isOffsetOp _ = False---- This expression should be an address from which a word can be loaded:--- check for funny-looking sub-word offsets.-_cmmCheckWordAddress :: CmmExpr -> CmmLint ()-_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0-  = cmmLintDubiousWordOffset e-_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0-  = cmmLintDubiousWordOffset e-_cmmCheckWordAddress _-  = return ()---- No warnings for unaligned arithmetic with the node register,--- which is used to extract fields from tagged constructor closures.-notNodeReg :: CmmExpr -> Bool-notNodeReg (CmmReg reg) | reg == nodeReg = False-notNodeReg _                             = True--}--lintCmmMiddle :: CmmNode O O -> CmmLint ()-lintCmmMiddle node = case node of-  CmmComment _ -> return ()-  CmmTick _    -> return ()-  CmmUnwind{}  -> return ()--  CmmAssign reg expr -> do-            dflags <- getDynFlags-            erep <- lintCmmExpr expr-            let reg_ty = cmmRegType dflags reg-            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)-                then return ()-                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty--  CmmStore l r -> do-            _ <- lintCmmExpr l-            _ <- lintCmmExpr r-            return ()--  CmmUnsafeForeignCall target _formals actuals -> do-            lintTarget target-            mapM_ lintCmmExpr actuals---lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()-lintCmmLast labels node = case node of-  CmmBranch id -> checkTarget id--  CmmCondBranch e t f _ -> do-            dflags <- getDynFlags-            mapM_ checkTarget [t,f]-            _ <- lintCmmExpr e-            checkCond dflags e--  CmmSwitch e ids -> do-            dflags <- getDynFlags-            mapM_ checkTarget $ switchTargetsToList ids-            erep <- lintCmmExpr e-            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)-              then return ()-              else cmmLintErr (text "switch scrutinee is not a word: " <>-                               ppr e <> text " :: " <> ppr erep)--  CmmCall { cml_target = target, cml_cont = cont } -> do-          _ <- lintCmmExpr target-          maybe (return ()) checkTarget cont--  CmmForeignCall tgt _ args succ _ _ _ -> do-          lintTarget tgt-          mapM_ lintCmmExpr args-          checkTarget succ- where-  checkTarget id-     | setMember id labels = return ()-     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)---lintTarget :: ForeignTarget -> CmmLint ()-lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()-lintTarget (PrimTarget {})     = return ()---checkCond :: DynFlags -> CmmExpr -> CmmLint ()-checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values-checkCond _ expr-    = cmmLintErr (hang (text "expression is not a conditional:") 2-                         (ppr expr))---- -------------------------------------------------------------------------------- CmmLint monad---- just a basic error monad:--newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }-    deriving (Functor)--instance Applicative CmmLint where-      pure a = CmmLint (\_ -> Right a)-      (<*>) = ap--instance Monad CmmLint where-  CmmLint m >>= k = CmmLint $ \dflags ->-                                case m dflags of-                                Left e -> Left e-                                Right a -> unCL (k a) dflags--instance HasDynFlags CmmLint where-    getDynFlags = CmmLint (\dflags -> Right dflags)--cmmLintErr :: SDoc -> CmmLint a-cmmLintErr msg = CmmLint (\_ -> Left msg)--addLintInfo :: SDoc -> CmmLint a -> CmmLint a-addLintInfo info thing = CmmLint $ \dflags ->-   case unCL thing dflags of-        Left err -> Left (hang info 2 err)-        Right a  -> Right a--cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a-cmmLintMachOpErr expr argsRep opExpectsRep-     = cmmLintErr (text "in MachOp application: " $$-                   nest 2 (ppr  expr) $$-                      (text "op is expecting: " <+> ppr opExpectsRep) $$-                      (text "arguments provide: " <+> ppr argsRep))--cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a-cmmLintAssignErr stmt e_ty r_ty-  = cmmLintErr (text "in assignment: " $$-                nest 2 (vcat [ppr stmt,-                              text "Reg ty:" <+> ppr r_ty,-                              text "Rhs ty:" <+> ppr e_ty]))---{--cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a-cmmLintDubiousWordOffset expr-   = cmmLintErr (text "offset is not a multiple of words: " $$-                 nest 2 (ppr expr))--}-
− compiler/cmm/CmmLive.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}--module CmmLive-    ( CmmLocalLive-    , cmmLocalLiveness-    , cmmGlobalLiveness-    , liveLattice-    , gen_kill-    )-where--import GhcPrelude--import DynFlags-import BlockId-import Cmm-import PprCmmExpr () -- For Outputable instances-import Hoopl.Block-import Hoopl.Collections-import Hoopl.Dataflow-import Hoopl.Label--import Maybes-import Outputable---------------------------------------------------------------------------------- Calculating what variables are live on entry to a basic block---------------------------------------------------------------------------------- | The variables live on entry to a block-type CmmLive r = RegSet r-type CmmLocalLive = CmmLive LocalReg---- | The dataflow lattice-liveLattice :: Ord r => DataflowLattice (CmmLive r)-{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}-{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}-liveLattice = DataflowLattice emptyRegSet add-  where-    add (OldFact old) (NewFact new) =-        let !join = plusRegSet old new-        in changedIf (sizeRegSet join > sizeRegSet old) join---- | A mapping from block labels to the variables live on entry-type BlockEntryLiveness r = LabelMap (CmmLive r)---------------------------------------------------------------------------------- | Calculated liveness info for a CmmGraph--------------------------------------------------------------------------------cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg-cmmLocalLiveness dflags graph =-    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty-  where-    entry = g_entry graph-    check facts =-        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts--cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg-cmmGlobalLiveness dflags graph =-    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty---- | On entry to the procedure, there had better not be any LocalReg's live-in.-noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a-noLiveOnEntry bid in_fact x =-  if nullRegSet in_fact then x-  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)--gen_kill-    :: (DefinerOfRegs r n, UserOfRegs r n)-    => DynFlags -> n -> CmmLive r -> CmmLive r-gen_kill dflags node set =-    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node-    in foldRegsUsed dflags extendRegSet afterKill node-{-# INLINE gen_kill #-}--xferLive-    :: forall r.-       ( UserOfRegs r (CmmNode O O)-       , DefinerOfRegs r (CmmNode O O)-       , UserOfRegs r (CmmNode O C)-       , DefinerOfRegs r (CmmNode O C)-       )-    => DynFlags -> TransferFun (CmmLive r)-xferLive dflags (BlockCC eNode middle xNode) fBase =-    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase-        !result = foldNodesBwdOO (gen_kill dflags) middle joined-    in mapSingleton (entryLabel eNode) result-{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}-{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
− compiler/cmm/CmmMachOp.hs 
@@ -1,664 +0,0 @@-module CmmMachOp-    ( MachOp(..)-    , pprMachOp, isCommutableMachOp, isAssociativeMachOp-    , isComparisonMachOp, maybeIntComparison, machOpResultType-    , machOpArgReps, maybeInvertComparison, isFloatComparison--    -- MachOp builders-    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot-    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem-    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe-    , mo_wordULe, mo_wordUGt, mo_wordULt-    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot-    , mo_wordShl, mo_wordSShr, mo_wordUShr-    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32-    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord-    , mo_u_32ToWord, mo_s_32ToWord-    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64--    -- CallishMachOp-    , CallishMachOp(..), callishMachOpHints-    , pprCallishMachOp-    , machOpMemcpyishAlign--    -- Atomic read-modify-write-    , AtomicMachOp(..)-   )-where--import GhcPrelude--import CmmType-import Outputable-import DynFlags----------------------------------------------------------------------------------              MachOp--------------------------------------------------------------------------------{- |-Machine-level primops; ones which we can reasonably delegate to the-native code generators to handle.--Most operations are parameterised by the 'Width' that they operate on.-Some operations have separate signed and unsigned versions, and float-and integer versions.--}--data MachOp-  -- Integer operations (insensitive to signed/unsigned)-  = MO_Add Width-  | MO_Sub Width-  | MO_Eq  Width-  | MO_Ne  Width-  | MO_Mul Width                -- low word of multiply--  -- Signed multiply/divide-  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows-  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)-  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)-  | MO_S_Neg  Width             -- unary ---  -- Unsigned multiply/divide-  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows-  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)-  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)--  -- Signed comparisons-  | MO_S_Ge Width-  | MO_S_Le Width-  | MO_S_Gt Width-  | MO_S_Lt Width--  -- Unsigned comparisons-  | MO_U_Ge Width-  | MO_U_Le Width-  | MO_U_Gt Width-  | MO_U_Lt Width--  -- Floating point arithmetic-  | MO_F_Add  Width-  | MO_F_Sub  Width-  | MO_F_Neg  Width             -- unary --  | MO_F_Mul  Width-  | MO_F_Quot Width--  -- Floating point comparison-  | MO_F_Eq Width-  | MO_F_Ne Width-  | MO_F_Ge Width-  | MO_F_Le Width-  | MO_F_Gt Width-  | MO_F_Lt Width--  -- Bitwise operations.  Not all of these may be supported-  -- at all sizes, and only integral Widths are valid.-  | MO_And   Width-  | MO_Or    Width-  | MO_Xor   Width-  | MO_Not   Width-  | MO_Shl   Width-  | MO_U_Shr Width      -- unsigned shift right-  | MO_S_Shr Width      -- signed shift right--  -- Conversions.  Some of these will be NOPs.-  -- Floating-point conversions use the signed variant.-  | MO_SF_Conv Width Width      -- Signed int -> Float-  | MO_FS_Conv Width Width      -- Float -> Signed int-  | MO_SS_Conv Width Width      -- Signed int -> Signed int-  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int-  | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the-                                -- contents of upper bits when extending;-                                -- narrowing is simply truncation; the only-                                -- expectation is that we can recover the-                                -- original value by applying the opposite-                                -- MO_XX_Conv, e.g.,-                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)-                                -- is equivalent to just x.-  | MO_FF_Conv Width Width      -- Float -> Float--  -- Vector element insertion and extraction operations-  | MO_V_Insert  Length Width   -- Insert scalar into vector-  | MO_V_Extract Length Width   -- Extract scalar from vector--  -- Integer vector operations-  | MO_V_Add Length Width-  | MO_V_Sub Length Width-  | MO_V_Mul Length Width--  -- Signed vector multiply/divide-  | MO_VS_Quot Length Width-  | MO_VS_Rem  Length Width-  | MO_VS_Neg  Length Width--  -- Unsigned vector multiply/divide-  | MO_VU_Quot Length Width-  | MO_VU_Rem  Length Width--  -- Floting point vector element insertion and extraction operations-  | MO_VF_Insert  Length Width   -- Insert scalar into vector-  | MO_VF_Extract Length Width   -- Extract scalar from vector--  -- Floating point vector operations-  | MO_VF_Add  Length Width-  | MO_VF_Sub  Length Width-  | MO_VF_Neg  Length Width      -- unary negation-  | MO_VF_Mul  Length Width-  | MO_VF_Quot Length Width--  -- Alignment check (for -falignment-sanitisation)-  | MO_AlignmentCheck Int Width-  deriving (Eq, Show)--pprMachOp :: MachOp -> SDoc-pprMachOp mo = text (show mo)------ -------------------------------------------------------------------------------- Some common MachReps---- A 'wordRep' is a machine word on the target architecture--- Specifically, it is the size of an Int#, Word#, Addr#--- and the unit of allocation on the stack and the heap--- Any pointer is also guaranteed to be a wordRep.--mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot-    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem-    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe-    , mo_wordULe, mo_wordUGt, mo_wordULt-    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr-    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord-    , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64-    :: DynFlags -> MachOp--mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32-    , mo_32To8, mo_32To16-    :: MachOp--mo_wordAdd      dflags = MO_Add (wordWidth dflags)-mo_wordSub      dflags = MO_Sub (wordWidth dflags)-mo_wordEq       dflags = MO_Eq  (wordWidth dflags)-mo_wordNe       dflags = MO_Ne  (wordWidth dflags)-mo_wordMul      dflags = MO_Mul (wordWidth dflags)-mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)-mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)-mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)-mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)-mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)--mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)-mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)-mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)-mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)--mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)-mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)-mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)-mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)--mo_wordAnd      dflags = MO_And (wordWidth dflags)-mo_wordOr       dflags = MO_Or  (wordWidth dflags)-mo_wordXor      dflags = MO_Xor (wordWidth dflags)-mo_wordNot      dflags = MO_Not (wordWidth dflags)-mo_wordShl      dflags = MO_Shl (wordWidth dflags)-mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)-mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)--mo_u_8To32             = MO_UU_Conv W8 W32-mo_s_8To32             = MO_SS_Conv W8 W32-mo_u_16To32            = MO_UU_Conv W16 W32-mo_s_16To32            = MO_SS_Conv W16 W32--mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)-mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)-mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)-mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)-mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)-mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)--mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8-mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16-mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32-mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64--mo_32To8               = MO_UU_Conv W32 W8-mo_32To16              = MO_UU_Conv W32 W16----- ------------------------------------------------------------------------------- isCommutableMachOp--{- |-Returns 'True' if the MachOp has commutable arguments.  This is used-in the platform-independent Cmm optimisations.--If in doubt, return 'False'.  This generates worse code on the-native routes, but is otherwise harmless.--}-isCommutableMachOp :: MachOp -> Bool-isCommutableMachOp mop =-  case mop of-        MO_Add _                -> True-        MO_Eq _                 -> True-        MO_Ne _                 -> True-        MO_Mul _                -> True-        MO_S_MulMayOflo _       -> True-        MO_U_MulMayOflo _       -> True-        MO_And _                -> True-        MO_Or _                 -> True-        MO_Xor _                -> True-        MO_F_Add _              -> True-        MO_F_Mul _              -> True-        _other                  -> False---- ------------------------------------------------------------------------------- isAssociativeMachOp--{- |-Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)-This is used in the platform-independent Cmm optimisations.--If in doubt, return 'False'.  This generates worse code on the-native routes, but is otherwise harmless.--}-isAssociativeMachOp :: MachOp -> Bool-isAssociativeMachOp mop =-  case mop of-        MO_Add {} -> True       -- NB: does not include-        MO_Mul {} -> True --     floatint point!-        MO_And {} -> True-        MO_Or  {} -> True-        MO_Xor {} -> True-        _other    -> False----- ------------------------------------------------------------------------------- isComparisonMachOp--{- |-Returns 'True' if the MachOp is a comparison.--If in doubt, return False.  This generates worse code on the-native routes, but is otherwise harmless.--}-isComparisonMachOp :: MachOp -> Bool-isComparisonMachOp mop =-  case mop of-    MO_Eq   _  -> True-    MO_Ne   _  -> True-    MO_S_Ge _  -> True-    MO_S_Le _  -> True-    MO_S_Gt _  -> True-    MO_S_Lt _  -> True-    MO_U_Ge _  -> True-    MO_U_Le _  -> True-    MO_U_Gt _  -> True-    MO_U_Lt _  -> True-    MO_F_Eq {} -> True-    MO_F_Ne {} -> True-    MO_F_Ge {} -> True-    MO_F_Le {} -> True-    MO_F_Gt {} -> True-    MO_F_Lt {} -> True-    _other     -> False--{- |-Returns @Just w@ if the operation is an integer comparison with width-@w@, or @Nothing@ otherwise.--}-maybeIntComparison :: MachOp -> Maybe Width-maybeIntComparison mop =-  case mop of-    MO_Eq   w  -> Just w-    MO_Ne   w  -> Just w-    MO_S_Ge w  -> Just w-    MO_S_Le w  -> Just w-    MO_S_Gt w  -> Just w-    MO_S_Lt w  -> Just w-    MO_U_Ge w  -> Just w-    MO_U_Le w  -> Just w-    MO_U_Gt w  -> Just w-    MO_U_Lt w  -> Just w-    _ -> Nothing--isFloatComparison :: MachOp -> Bool-isFloatComparison mop =-  case mop of-    MO_F_Eq {} -> True-    MO_F_Ne {} -> True-    MO_F_Ge {} -> True-    MO_F_Le {} -> True-    MO_F_Gt {} -> True-    MO_F_Lt {} -> True-    _other     -> False---- -------------------------------------------------------------------------------- Inverting conditions---- Sometimes it's useful to be able to invert the sense of a--- condition.  Not all conditional tests are invertible: in--- particular, floating point conditionals cannot be inverted, because--- there exist floating-point values which return False for both senses--- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).--maybeInvertComparison :: MachOp -> Maybe MachOp-maybeInvertComparison op-  = case op of  -- None of these Just cases include floating point-        MO_Eq r   -> Just (MO_Ne r)-        MO_Ne r   -> Just (MO_Eq r)-        MO_U_Lt r -> Just (MO_U_Ge r)-        MO_U_Gt r -> Just (MO_U_Le r)-        MO_U_Le r -> Just (MO_U_Gt r)-        MO_U_Ge r -> Just (MO_U_Lt r)-        MO_S_Lt r -> Just (MO_S_Ge r)-        MO_S_Gt r -> Just (MO_S_Le r)-        MO_S_Le r -> Just (MO_S_Gt r)-        MO_S_Ge r -> Just (MO_S_Lt r)-        _other    -> Nothing---- ------------------------------------------------------------------------------- machOpResultType--{- |-Returns the MachRep of the result of a MachOp.--}-machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType-machOpResultType dflags mop tys =-  case mop of-    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood-    MO_Sub {}           -> ty1  -- of first arg-    MO_Mul    r         -> cmmBits r-    MO_S_MulMayOflo r   -> cmmBits r-    MO_S_Quot r         -> cmmBits r-    MO_S_Rem  r         -> cmmBits r-    MO_S_Neg  r         -> cmmBits r-    MO_U_MulMayOflo r   -> cmmBits r-    MO_U_Quot r         -> cmmBits r-    MO_U_Rem  r         -> cmmBits r--    MO_Eq {}            -> comparisonResultRep dflags-    MO_Ne {}            -> comparisonResultRep dflags-    MO_S_Ge {}          -> comparisonResultRep dflags-    MO_S_Le {}          -> comparisonResultRep dflags-    MO_S_Gt {}          -> comparisonResultRep dflags-    MO_S_Lt {}          -> comparisonResultRep dflags--    MO_U_Ge {}          -> comparisonResultRep dflags-    MO_U_Le {}          -> comparisonResultRep dflags-    MO_U_Gt {}          -> comparisonResultRep dflags-    MO_U_Lt {}          -> comparisonResultRep dflags--    MO_F_Add r          -> cmmFloat r-    MO_F_Sub r          -> cmmFloat r-    MO_F_Mul r          -> cmmFloat r-    MO_F_Quot r         -> cmmFloat r-    MO_F_Neg r          -> cmmFloat r-    MO_F_Eq  {}         -> comparisonResultRep dflags-    MO_F_Ne  {}         -> comparisonResultRep dflags-    MO_F_Ge  {}         -> comparisonResultRep dflags-    MO_F_Le  {}         -> comparisonResultRep dflags-    MO_F_Gt  {}         -> comparisonResultRep dflags-    MO_F_Lt  {}         -> comparisonResultRep dflags--    MO_And {}           -> ty1  -- Used for pointer masking-    MO_Or {}            -> ty1-    MO_Xor {}           -> ty1-    MO_Not   r          -> cmmBits r-    MO_Shl   r          -> cmmBits r-    MO_U_Shr r          -> cmmBits r-    MO_S_Shr r          -> cmmBits r--    MO_SS_Conv _ to     -> cmmBits to-    MO_UU_Conv _ to     -> cmmBits to-    MO_XX_Conv _ to     -> cmmBits to-    MO_FS_Conv _ to     -> cmmBits to-    MO_SF_Conv _ to     -> cmmFloat to-    MO_FF_Conv _ to     -> cmmFloat to--    MO_V_Insert  l w    -> cmmVec l (cmmBits w)-    MO_V_Extract _ w    -> cmmBits w--    MO_V_Add l w        -> cmmVec l (cmmBits w)-    MO_V_Sub l w        -> cmmVec l (cmmBits w)-    MO_V_Mul l w        -> cmmVec l (cmmBits w)--    MO_VS_Quot l w      -> cmmVec l (cmmBits w)-    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)-    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)--    MO_VU_Quot l w      -> cmmVec l (cmmBits w)-    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)--    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)-    MO_VF_Extract _ w   -> cmmFloat w--    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)-    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)-    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)-    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)-    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)--    MO_AlignmentCheck _ _ -> ty1-  where-    (ty1:_) = tys--comparisonResultRep :: DynFlags -> CmmType-comparisonResultRep = bWord  -- is it?----- -------------------------------------------------------------------------------- machOpArgReps---- | This function is used for debugging only: we can check whether an--- application of a MachOp is "type-correct" by checking that the MachReps of--- its arguments are the same as the MachOp expects.  This is used when--- linting a CmmExpr.--machOpArgReps :: DynFlags -> MachOp -> [Width]-machOpArgReps dflags op =-  case op of-    MO_Add    r         -> [r,r]-    MO_Sub    r         -> [r,r]-    MO_Eq     r         -> [r,r]-    MO_Ne     r         -> [r,r]-    MO_Mul    r         -> [r,r]-    MO_S_MulMayOflo r   -> [r,r]-    MO_S_Quot r         -> [r,r]-    MO_S_Rem  r         -> [r,r]-    MO_S_Neg  r         -> [r]-    MO_U_MulMayOflo r   -> [r,r]-    MO_U_Quot r         -> [r,r]-    MO_U_Rem  r         -> [r,r]--    MO_S_Ge r           -> [r,r]-    MO_S_Le r           -> [r,r]-    MO_S_Gt r           -> [r,r]-    MO_S_Lt r           -> [r,r]--    MO_U_Ge r           -> [r,r]-    MO_U_Le r           -> [r,r]-    MO_U_Gt r           -> [r,r]-    MO_U_Lt r           -> [r,r]--    MO_F_Add r          -> [r,r]-    MO_F_Sub r          -> [r,r]-    MO_F_Mul r          -> [r,r]-    MO_F_Quot r         -> [r,r]-    MO_F_Neg r          -> [r]-    MO_F_Eq  r          -> [r,r]-    MO_F_Ne  r          -> [r,r]-    MO_F_Ge  r          -> [r,r]-    MO_F_Le  r          -> [r,r]-    MO_F_Gt  r          -> [r,r]-    MO_F_Lt  r          -> [r,r]--    MO_And   r          -> [r,r]-    MO_Or    r          -> [r,r]-    MO_Xor   r          -> [r,r]-    MO_Not   r          -> [r]-    MO_Shl   r          -> [r, wordWidth dflags]-    MO_U_Shr r          -> [r, wordWidth dflags]-    MO_S_Shr r          -> [r, wordWidth dflags]--    MO_SS_Conv from _   -> [from]-    MO_UU_Conv from _   -> [from]-    MO_XX_Conv from _   -> [from]-    MO_SF_Conv from _   -> [from]-    MO_FS_Conv from _   -> [from]-    MO_FF_Conv from _   -> [from]--    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]-    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]--    MO_V_Add _ r        -> [r,r]-    MO_V_Sub _ r        -> [r,r]-    MO_V_Mul _ r        -> [r,r]--    MO_VS_Quot _ r      -> [r,r]-    MO_VS_Rem  _ r      -> [r,r]-    MO_VS_Neg  _ r      -> [r]--    MO_VU_Quot _ r      -> [r,r]-    MO_VU_Rem  _ r      -> [r,r]--    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]-    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]--    MO_VF_Add  _ r      -> [r,r]-    MO_VF_Sub  _ r      -> [r,r]-    MO_VF_Mul  _ r      -> [r,r]-    MO_VF_Quot _ r      -> [r,r]-    MO_VF_Neg  _ r      -> [r]--    MO_AlignmentCheck _ r -> [r]---------------------------------------------------------------------------------- CallishMachOp---------------------------------------------------------------------------------- CallishMachOps tend to be implemented by foreign calls in some backends,--- so we separate them out.  In Cmm, these can only occur in a--- statement position, in contrast to an ordinary MachOp which can occur--- anywhere in an expression.-data CallishMachOp-  = MO_F64_Pwr-  | MO_F64_Sin-  | MO_F64_Cos-  | MO_F64_Tan-  | MO_F64_Sinh-  | MO_F64_Cosh-  | MO_F64_Tanh-  | MO_F64_Asin-  | MO_F64_Acos-  | MO_F64_Atan-  | MO_F64_Asinh-  | MO_F64_Acosh-  | MO_F64_Atanh-  | MO_F64_Log-  | MO_F64_Log1P-  | MO_F64_Exp-  | MO_F64_ExpM1-  | MO_F64_Fabs-  | MO_F64_Sqrt-  | MO_F32_Pwr-  | MO_F32_Sin-  | MO_F32_Cos-  | MO_F32_Tan-  | MO_F32_Sinh-  | MO_F32_Cosh-  | MO_F32_Tanh-  | MO_F32_Asin-  | MO_F32_Acos-  | MO_F32_Atan-  | MO_F32_Asinh-  | MO_F32_Acosh-  | MO_F32_Atanh-  | MO_F32_Log-  | MO_F32_Log1P-  | MO_F32_Exp-  | MO_F32_ExpM1-  | MO_F32_Fabs-  | MO_F32_Sqrt--  | MO_UF_Conv Width--  | MO_S_Mul2    Width-  | MO_S_QuotRem Width-  | MO_U_QuotRem Width-  | MO_U_QuotRem2 Width-  | MO_Add2      Width-  | MO_AddWordC  Width-  | MO_SubWordC  Width-  | MO_AddIntC   Width-  | MO_SubIntC   Width-  | MO_U_Mul2    Width--  | MO_ReadBarrier-  | MO_WriteBarrier-  | MO_Touch         -- Keep variables live (when using interior pointers)--  -- Prefetch-  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not-                     -- program behavior.-                     -- the Int can be 0-3. Needs to be known at compile time-                     -- to interact with code generation correctly.-                     --  TODO: add support for prefetch WRITES,-                     --  currently only exposes prefetch reads, which-                     -- would the majority of use cases in ghc anyways---  -- These three MachOps are parameterised by the known alignment-  -- of the destination and source (for memcpy/memmove) pointers.-  -- This information may be used for optimisation in backends.-  | MO_Memcpy Int-  | MO_Memset Int-  | MO_Memmove Int-  | MO_Memcmp Int--  | MO_PopCnt Width-  | MO_Pdep Width-  | MO_Pext Width-  | MO_Clz Width-  | MO_Ctz Width--  | MO_BSwap Width-  | MO_BRev Width--  -- Atomic read-modify-write.-  | MO_AtomicRMW Width AtomicMachOp-  | MO_AtomicRead Width-  | MO_AtomicWrite Width-  | MO_Cmpxchg Width-  deriving (Eq, Show)---- | The operation to perform atomically.-data AtomicMachOp =-      AMO_Add-    | AMO_Sub-    | AMO_And-    | AMO_Nand-    | AMO_Or-    | AMO_Xor-      deriving (Eq, Show)--pprCallishMachOp :: CallishMachOp -> SDoc-pprCallishMachOp mo = text (show mo)--callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])-callishMachOpHints op = case op of-  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])-  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])-  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])-  MO_Memcmp _  -> ([], [AddrHint, AddrHint, NoHint])-  _            -> ([],[])-  -- empty lists indicate NoHint---- | The alignment of a 'memcpy'-ish operation.-machOpMemcpyishAlign :: CallishMachOp -> Maybe Int-machOpMemcpyishAlign op = case op of-  MO_Memcpy  align -> Just align-  MO_Memset  align -> Just align-  MO_Memmove align -> Just align-  MO_Memcmp  align -> Just align-  _                -> Nothing
− compiler/cmm/CmmMonad.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- A Parser monad with access to the 'DynFlags'.------ The 'P' monad  only has access to the subset of of 'DynFlags'--- required for parsing Haskell.---- The parser for C-- requires access to a lot more of the 'DynFlags',--- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.-------------------------------------------------------------------------------module CmmMonad (-    PD(..)-  , liftP-  ) where--import GhcPrelude--import Control.Monad-import qualified Control.Monad.Fail as MonadFail--import DynFlags-import Lexer--newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }--instance Functor PD where-  fmap = liftM--instance Applicative PD where-  pure = returnPD-  (<*>) = ap--instance Monad PD where-  (>>=) = thenPD-#if !MIN_VERSION_base(4,13,0)-  fail = MonadFail.fail-#endif--instance MonadFail.MonadFail PD where-  fail = failPD--liftP :: P a -> PD a-liftP (P f) = PD $ \_ s -> f s--returnPD :: a -> PD a-returnPD = liftP . return--thenPD :: PD a -> (a -> PD b) -> PD b-(PD m) `thenPD` k = PD $ \d s ->-        case m d s of-                POk s1 a         -> unPD (k a) d s1-                PFailed s1 -> PFailed s1--failPD :: String -> PD a-failPD = liftP . fail--instance HasDynFlags PD where-   getDynFlags = PD $ \d s -> POk s d
− compiler/cmm/CmmNode.hs 
@@ -1,724 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}----- CmmNode type for representation using Hoopl graphs.--module CmmNode (-     CmmNode(..), CmmFormal, CmmActual, CmmTickish,-     UpdFrameOffset, Convention(..),-     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,-     CmmReturnInfo(..),-     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,-     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,--     -- * Tick scopes-     CmmTickScope(..), isTickSubScope, combineTickScopes,-  ) where--import GhcPrelude hiding (succ)--import GHC.Platform.Regs-import CmmExpr-import CmmSwitch-import DynFlags-import FastString-import ForeignCall-import Outputable-import SMRep-import CoreSyn (Tickish)-import qualified Unique as U--import Hoopl.Block-import Hoopl.Graph-import Hoopl.Collections-import Hoopl.Label-import Data.Maybe-import Data.List (tails,sortBy)-import Unique (nonDetCmpUnique)-import Util------------------------------ CmmNode--#define ULabel {-# UNPACK #-} !Label--data CmmNode e x where-  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O--  CmmComment :: FastString -> CmmNode O O--    -- Tick annotation, covering Cmm code in our tick scope. We only-    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).-    -- See Note [CmmTick scoping details]-  CmmTick :: !CmmTickish -> CmmNode O O--    -- Unwind pseudo-instruction, encoding stack unwinding-    -- instructions for a debugger. This describes how to reconstruct-    -- the "old" value of a register if we want to navigate the stack-    -- up one frame. Having unwind information for @Sp@ will allow the-    -- debugger to "walk" the stack.-    ---    -- See Note [What is this unwinding business?] in Debug-  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O--  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O-    -- Assign to register--  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O-    -- Assign to memory location.  Size is-    -- given by cmmExprType of the rhs.--  CmmUnsafeForeignCall ::       -- An unsafe foreign call;-                                -- see Note [Foreign calls]-                                -- Like a "fat machine instruction"; can occur-                                -- in the middle of a block-      ForeignTarget ->          -- call target-      [CmmFormal] ->            -- zero or more results-      [CmmActual] ->            -- zero or more arguments-      CmmNode O O-      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True-      -- See Note [Unsafe foreign calls clobber caller-save registers]-      ---      -- Invariant: the arguments and the ForeignTarget must not-      -- mention any registers for which GHC.Platform.callerSaves-      -- is True.  See Note [Register Parameter Passing].--  CmmBranch :: ULabel -> CmmNode O C-                                   -- Goto another block in the same procedure--  CmmCondBranch :: {                 -- conditional branch-      cml_pred :: CmmExpr,-      cml_true, cml_false :: ULabel,-      cml_likely :: Maybe Bool       -- likely result of the conditional,-                                     -- if known-  } -> CmmNode O C--  CmmSwitch-    :: CmmExpr       -- Scrutinee, of some integral type-    -> SwitchTargets -- Cases. See [Note SwitchTargets]-    -> CmmNode O C--  CmmCall :: {                -- A native call or tail call-      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!--      cml_cont :: Maybe Label,-          -- Label of continuation (Nothing for return or tail call)-          ---          -- Note [Continuation BlockIds]: these BlockIds are called-          -- Continuation BlockIds, and are the only BlockIds that can-          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or-          -- (CmmStackSlot (Young b) _).--      cml_args_regs :: [GlobalReg],-          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed-          -- to the call.  This is essential information for the-          -- native code generator's register allocator; without-          -- knowing which GlobalRegs are live it has to assume that-          -- they are all live.  This list should only include-          -- GlobalRegs that are mapped to real machine registers on-          -- the target platform.--      cml_args :: ByteOff,-          -- Byte offset, from the *old* end of the Area associated with-          -- the Label (if cml_cont = Nothing, then Old area), of-          -- youngest outgoing arg.  Set the stack pointer to this before-          -- transferring control.-          -- (NB: an update frame might also have been stored in the Old-          --      area, but it'll be in an older part than the args.)--      cml_ret_args :: ByteOff,-          -- For calls *only*, the byte offset for youngest returned value-          -- This is really needed at the *return* point rather than here-          -- at the call, but in practice it's convenient to record it here.--      cml_ret_off :: ByteOff-        -- For calls *only*, the byte offset of the base of the frame that-        -- must be described by the info table for the return point.-        -- The older words are an update frames, which have their own-        -- info-table and layout information--        -- From a liveness point of view, the stack words older than-        -- cml_ret_off are treated as live, even if the sequel of-        -- the call goes into a loop.-  } -> CmmNode O C--  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]-                                -- Always the last node of a block-      tgt   :: ForeignTarget,   -- call target and convention-      res   :: [CmmFormal],     -- zero or more results-      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]-      succ  :: ULabel,          -- Label of continuation-      ret_args :: ByteOff,      -- same as cml_ret_args-      ret_off :: ByteOff,       -- same as cml_ret_off-      intrbl:: Bool             -- whether or not the call is interruptible-  } -> CmmNode O C--{- Note [Foreign calls]-~~~~~~~~~~~~~~~~~~~~~~~-A CmmUnsafeForeignCall is used for *unsafe* foreign calls;-a CmmForeignCall call is used for *safe* foreign calls.--Unsafe ones are mostly easy: think of them as a "fat machine-instruction".  In particular, they do *not* kill all live registers,-just the registers they return to (there was a bit of code in GHC that-conservatively assumed otherwise.)  However, see [Register parameter passing].--Safe ones are trickier.  A safe foreign call-     r = f(x)-ultimately expands to-     push "return address"      -- Never used to return to;-                                -- just points an info table-     save registers into TSO-     call suspendThread-     r = f(x)                   -- Make the call-     call resumeThread-     restore registers-     pop "return address"-We cannot "lower" a safe foreign call to this sequence of Cmms, because-after we've saved Sp all the Cmm optimiser's assumptions are broken.--Note that a safe foreign call needs an info table.--So Safe Foreign Calls must remain as last nodes until the stack is-made manifest in CmmLayoutStack, where they are lowered into the above-sequence.--}--{- Note [Unsafe foreign calls clobber caller-save registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A foreign call is defined to clobber any GlobalRegs that are mapped to-caller-saves machine registers (according to the prevailing C ABI).-GHC.StgToCmm.Utils.callerSaves tells you which GlobalRegs are caller-saves.--This is a design choice that makes it easier to generate code later.-We could instead choose to say that foreign calls do *not* clobber-caller-saves regs, but then we would have to figure out which regs-were live across the call later and insert some saves/restores.--Furthermore when we generate code we never have any GlobalRegs live-across a call, because they are always copied-in to LocalRegs and-copied-out again before making a call/jump.  So all we have to do is-avoid any code motion that would make a caller-saves GlobalReg live-across a foreign call during subsequent optimisations.--}--{- Note [Register parameter passing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On certain architectures, some registers are utilized for parameter-passing in the C calling convention.  For example, in x86-64 Linux-convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for-argument passing.  These are registers R3-R6, which our generated-code may also be using; as a result, it's necessary to save these-values before doing a foreign call.  This is done during initial-code generation in callerSaveVolatileRegs in GHC.StgToCmm.Utils.  However,-one result of doing this is that the contents of these registers-may mysteriously change if referenced inside the arguments.  This-is dangerous, so you'll need to disable inlining much in the same-way is done in cmm/CmmOpt.hs currently.  We should fix this!--}-------------------------------------------------- Eq instance of CmmNode--deriving instance Eq (CmmNode e x)--------------------------------------------------- Hoopl instances of CmmNode--instance NonLocal CmmNode where-  entryLabel (CmmEntry l _) = l--  successors (CmmBranch l) = [l]-  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint-  successors (CmmSwitch _ ids) = switchTargetsToList ids-  successors (CmmCall {cml_cont=l}) = maybeToList l-  successors (CmmForeignCall {succ=l}) = [l]-------------------------------------------------------- Various helper types--type CmmActual = CmmExpr-type CmmFormal = LocalReg--type UpdFrameOffset = ByteOff---- | A convention maps a list of values (function arguments or return--- values) to registers or stack locations.-data Convention-  = NativeDirectCall-       -- ^ top-level Haskell functions use @NativeDirectCall@, which-       -- maps arguments to registers starting with R2, according to-       -- how many registers are available on the platform.  This-       -- convention ignores R1, because for a top-level function call-       -- the function closure is implicit, and doesn't need to be passed.-  | NativeNodeCall-       -- ^ non-top-level Haskell functions, which pass the address of-       -- the function closure in R1 (regardless of whether R1 is a-       -- real register or not), and the rest of the arguments in-       -- registers or on the stack.-  | NativeReturn-       -- ^ a native return.  The convention for returns depends on-       -- how many values are returned: for just one value returned,-       -- the appropriate register is used (R1, F1, etc.). regardless-       -- of whether it is a real register or not.  For multiple-       -- values returned, they are mapped to registers or the stack.-  | Slow-       -- ^ Slow entry points: all args pushed on the stack-  | GC-       -- ^ Entry to the garbage collector: uses the node reg!-       -- (TODO: I don't think we need this --SDM)-  deriving( Eq )--data ForeignConvention-  = ForeignConvention-        CCallConv               -- Which foreign-call convention-        [ForeignHint]           -- Extra info about the args-        [ForeignHint]           -- Extra info about the result-        CmmReturnInfo-  deriving Eq--data CmmReturnInfo-  = CmmMayReturn-  | CmmNeverReturns-  deriving ( Eq )--data ForeignTarget        -- The target of a foreign call-  = ForeignTarget                -- A foreign procedure-        CmmExpr                  -- Its address-        ForeignConvention        -- Its calling convention-  | PrimTarget            -- A possibly-side-effecting machine operation-        CallishMachOp            -- Which one-  deriving Eq--foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])-foreignTargetHints target-  = ( res_hints ++ repeat NoHint-    , arg_hints ++ repeat NoHint )-  where-    (res_hints, arg_hints) =-       case target of-          PrimTarget op -> callishMachOpHints op-          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->-             (res_hints, arg_hints)------------------------------------------------------- Instances of register and slot users / definers--instance UserOfRegs LocalReg (CmmNode e x) where-  foldRegsUsed dflags f !z n = case n of-    CmmAssign _ expr -> fold f z expr-    CmmStore addr rval -> fold f (fold f z addr) rval-    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args-    CmmCondBranch expr _ _ _ -> fold f z expr-    CmmSwitch expr _ -> fold f z expr-    CmmCall {cml_target=tgt} -> fold f z tgt-    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args-    _ -> z-    where fold :: forall a b. UserOfRegs LocalReg a-               => (b -> LocalReg -> b) -> b -> a -> b-          fold f z n = foldRegsUsed dflags f z n--instance UserOfRegs GlobalReg (CmmNode e x) where-  foldRegsUsed dflags f !z n = case n of-    CmmAssign _ expr -> fold f z expr-    CmmStore addr rval -> fold f (fold f z addr) rval-    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args-    CmmCondBranch expr _ _ _ -> fold f z expr-    CmmSwitch expr _ -> fold f z expr-    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt-    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args-    _ -> z-    where fold :: forall a b.  UserOfRegs GlobalReg a-               => (b -> GlobalReg -> b) -> b -> a -> b-          fold f z n = foldRegsUsed dflags f z n--instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where-  -- The (Ord r) in the context is necessary here-  -- See Note [Recursive superclasses] in TcInstDcls-  foldRegsUsed _      _ !z (PrimTarget _)      = z-  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e--instance DefinerOfRegs LocalReg (CmmNode e x) where-  foldRegsDefd dflags f !z n = case n of-    CmmAssign lhs _ -> fold f z lhs-    CmmUnsafeForeignCall _ fs _ -> fold f z fs-    CmmForeignCall {res=res} -> fold f z res-    _ -> z-    where fold :: forall a b. DefinerOfRegs LocalReg a-               => (b -> LocalReg -> b) -> b -> a -> b-          fold f z n = foldRegsDefd dflags f z n--instance DefinerOfRegs GlobalReg (CmmNode e x) where-  foldRegsDefd dflags f !z n = case n of-    CmmAssign lhs _ -> fold f z lhs-    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)-    CmmCall        {} -> fold f z activeRegs-    CmmForeignCall {} -> fold f z activeRegs-                      -- See Note [Safe foreign calls clobber STG registers]-    _ -> z-    where fold :: forall a b. DefinerOfRegs GlobalReg a-               => (b -> GlobalReg -> b) -> b -> a -> b-          fold f z n = foldRegsDefd dflags f z n--          platform = targetPlatform dflags-          activeRegs = activeStgRegs platform-          activeCallerSavesRegs = filter (callerSaves platform) activeRegs--          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []-          foreignTargetRegs _ = activeCallerSavesRegs---- Note [Safe foreign calls clobber STG registers]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ During stack layout phase every safe foreign call is expanded into a block--- that contains unsafe foreign call (instead of safe foreign call) and ends--- with a normal call (See Note [Foreign calls]). This means that we must--- treat safe foreign call as if it was a normal call (because eventually it--- will be). This is important if we try to run sinking pass before stack--- layout phase. Consider this example of what might go wrong (this is cmm--- code from stablename001 test). Here is code after common block elimination--- (before stack layout):------  c1q6:---      _s1pf::P64 = R1;---      _c1q8::I64 = performMajorGC;---      I64[(young<c1q9> + 8)] = c1q9;---      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)---                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;---  c1q9:---      I64[(young<c1qb> + 8)] = c1qb;---      R1 = _s1pc::P64;---      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;------ If we run sinking pass now (still before stack layout) we will get this:------  c1q6:---      I64[(young<c1q9> + 8)] = c1q9;---      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)---                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;---  c1q9:---      I64[(young<c1qb> + 8)] = c1qb;---      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call---      R1 = _s1pc::P64;---      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;------ Notice that _s1pf was sunk past a foreign call. When we run stack layout--- safe call to performMajorGC will be turned into:------  c1q6:---      _s1pc::P64 = P64[Sp + 8];---      I64[Sp - 8] = c1q9;---      Sp = Sp - 8;---      I64[I64[CurrentTSO + 24] + 16] = Sp;---      P64[CurrentNursery + 8] = Hp + 8;---      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]---                           result hints:  [PtrHint] suspendThread(BaseReg, 0);---      call "ccall" arg hints:  []  result hints:  [] performMajorGC();---      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]---                           result hints:  [PtrHint] resumeThread(_u1qI::I64);---      BaseReg = _u1qJ::I64;---      _u1qK::P64 = CurrentTSO;---      _u1qL::P64 = I64[_u1qK::P64 + 24];---      Sp = I64[_u1qL::P64 + 16];---      SpLim = _u1qL::P64 + 192;---      HpAlloc = 0;---      Hp = I64[CurrentNursery + 8] - 8;---      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);---      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;---  c1q9:---      I64[(young<c1qb> + 8)] = c1qb;---      _s1pf::P64 = R1;         <------ INCORRECT!---      R1 = _s1pc::P64;---      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;------ Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that--- call is clearly incorrect. This is what would happen if we assumed that--- safe foreign call has the same semantics as unsafe foreign call. To prevent--- this we need to treat safe foreign call as if was normal call.---------------------------------------- mapping Expr in CmmNode--mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget-mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c-mapForeignTarget _   m@(PrimTarget _)      = m--wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr--- Take a transformer on expressions and apply it recursively.--- (wrapRecExp f e) first recursively applies itself to sub-expressions of e---                  then  uses f to rewrite the resulting expression-wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)-wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)-wrapRecExp f e                    = f e--mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x-mapExp _ f@(CmmEntry{})                          = f-mapExp _ m@(CmmComment _)                        = m-mapExp _ m@(CmmTick _)                           = m-mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)-mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)-mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)-mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)-mapExp _ l@(CmmBranch _)                         = l-mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l-mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids-mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}-mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl--mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x-mapExpDeep f = mapExp $ wrapRecExp f----------------------------------------------------------------------------- mapping Expr in CmmNode, but not performing allocation if no changes--mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget-mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e-mapForeignTargetM _ (PrimTarget _)      = Nothing--wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)--- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e---                   then  gives f a chance to rewrite the resulting expression-wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)-wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)-wrapRecExpM f e                    = f e--mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)-mapExpM _ (CmmEntry{})              = Nothing-mapExpM _ (CmmComment _)            = Nothing-mapExpM _ (CmmTick _)               = Nothing-mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs-mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e-mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]-mapExpM _ (CmmBranch _)             = Nothing-mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e-mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e-mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt-mapExpM f (CmmUnsafeForeignCall tgt fs as)-    = case mapForeignTargetM f tgt of-        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))-        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as-mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)-    = case mapForeignTargetM f tgt of-        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)-        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as---- share as much as possible-mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]-mapListM f xs = let (b, r) = mapListT f xs-                in if b then Just r else Nothing--mapListJ :: (a -> Maybe a) -> [a] -> [a]-mapListJ f xs = snd (mapListT f xs)--mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])-mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))-    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)-          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)-          g (ys', _, Nothing) (False, _)  = (False, ys')-          g (_,   _, Just y)  (False, ys) = (True,  y:ys)--mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)-mapExpDeepM f = mapExpM $ wrapRecExpM f---------------------------------------- folding Expr in CmmNode--foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z-foldExpForeignTarget exp (ForeignTarget e _) z = exp e z-foldExpForeignTarget _   (PrimTarget _)      z = z---- Take a folder on expressions and apply it recursively.--- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad--- itself, delegating all the other CmmExpr forms to 'f'.-wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z-wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es-wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)-wrapRecExpf f e                  z = f e z--foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z-foldExp _ (CmmEntry {}) z                         = z-foldExp _ (CmmComment {}) z                       = z-foldExp _ (CmmTick {}) z                          = z-foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)-foldExp f (CmmAssign _ e) z                       = f e z-foldExp f (CmmStore addr e) z                     = f addr $ f e z-foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as-foldExp _ (CmmBranch _) z                         = z-foldExp f (CmmCondBranch e _ _ _) z               = f e z-foldExp f (CmmSwitch e _) z                       = f e z-foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z-foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args--foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z-foldExpDeep f = foldExp (wrapRecExpf f)---- -------------------------------------------------------------------------------mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C-mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)-mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l-mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)-mapSuccessors _ n = n--mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C-                     -> (CmmNode O C, [a])-mapCollectSuccessors f (CmmBranch bid)-  = let (bid', acc) = f bid in (CmmBranch bid', [acc])-mapCollectSuccessors f (CmmCondBranch p y n l)-  = let (bidt, acct) = f y-        (bidf, accf) = f n-    in  (CmmCondBranch p bidt bidf l, [accf, acct])-mapCollectSuccessors f (CmmSwitch e ids)-  = let lbls = switchTargetsToList ids :: [Label]-        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)-    in ( CmmSwitch e-          (mapSwitchTargets-            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)-          , map snd (mapElems lblMap)-        )-mapCollectSuccessors _ n = (n, [])---- --------------------------------------------------------------------------------- | Tickish in Cmm context (annotations only)-type CmmTickish = Tickish ()---- | Tick scope identifier, allowing us to reason about what--- annotations in a Cmm block should scope over. We especially take--- care to allow optimisations to reorganise blocks without losing--- tick association in the process.-data CmmTickScope-  = GlobalScope-    -- ^ The global scope is the "root" of the scope graph. Every-    -- scope is a sub-scope of the global scope. It doesn't make sense-    -- to add ticks to this scope. On the other hand, this means that-    -- setting this scope on a block means no ticks apply to it.--  | SubScope !U.Unique CmmTickScope-    -- ^ Constructs a new sub-scope to an existing scope. This allows-    -- us to translate Core-style scoping rules (see @tickishScoped@)-    -- into the Cmm world. Suppose the following code:-    ---    --   tick<1> case ... of-    --             A -> tick<2> ...-    --             B -> tick<3> ...-    ---    -- We want the top-level tick annotation to apply to blocks-    -- generated for the A and B alternatives. We can achieve that by-    -- generating tick<1> into a block with scope a, while the code-    -- for alternatives A and B gets generated into sub-scopes a/b and-    -- a/c respectively.--  | CombinedScope CmmTickScope CmmTickScope-    -- ^ A combined scope scopes over everything that the two given-    -- scopes cover. It is therefore a sub-scope of either scope. This-    -- is required for optimisations. Consider common block elimination:-    ---    --   A -> tick<2> case ... of-    --     C -> [common]-    --   B -> tick<3> case ... of-    --     D -> [common]-    ---    -- We will generate code for the C and D alternatives, and figure-    -- out afterwards that it's actually common code. Scoping rules-    -- dictate that the resulting common block needs to be covered by-    -- both tick<2> and tick<3>, therefore we need to construct a-    -- scope that is a child to *both* scope. Now we can do that - if-    -- we assign the scopes a/c and b/d to the common-ed up blocks,-    -- the new block could have a combined tick scope a/c+b/d, which-    -- both tick<2> and tick<3> apply to.---- Note [CmmTick scoping details]:------ The scope of a @CmmTick@ is given by the @CmmEntry@ node of the--- same block. Note that as a result of this, optimisations making--- tick scopes more specific can *reduce* the amount of code a tick--- scopes over. Fixing this would require a separate @CmmTickScope@--- field for @CmmTick@. Right now we do not do this simply because I--- couldn't find an example where it actually mattered -- multiple--- blocks within the same scope generally jump to each other, which--- prevents common block elimination from happening in the first--- place. But this is no strong reason, so if Cmm optimisations become--- more involved in future this might have to be revisited.---- | Output all scope paths.-scopeToPaths :: CmmTickScope -> [[U.Unique]]-scopeToPaths GlobalScope           = [[]]-scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)-scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2---- | Returns the head uniques of the scopes. This is based on the--- assumption that the @Unique@ of @SubScope@ identifies the--- underlying super-scope. Used for efficient equality and comparison,--- see below.-scopeUniques :: CmmTickScope -> [U.Unique]-scopeUniques GlobalScope           = []-scopeUniques (SubScope u _)        = [u]-scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2---- Equality and order is based on the head uniques defined above. We--- take care to short-cut the (extremely) common cases.-instance Eq CmmTickScope where-  GlobalScope    == GlobalScope     = True-  GlobalScope    == _               = False-  _              == GlobalScope     = False-  (SubScope u _) == (SubScope u' _) = u == u'-  (SubScope _ _) == _               = False-  _              == (SubScope _ _)  = False-  scope          == scope'          =-    sortBy nonDetCmpUnique (scopeUniques scope) ==-    sortBy nonDetCmpUnique (scopeUniques scope')-    -- This is still deterministic because-    -- the order is the same for equal lists---- This is non-deterministic but we do not currently support deterministic--- code-generation. See Note [Unique Determinism and code generation]--- See Note [No Ord for Unique]-instance Ord CmmTickScope where-  compare GlobalScope    GlobalScope     = EQ-  compare GlobalScope    _               = LT-  compare _              GlobalScope     = GT-  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'-  compare scope scope'                   = cmpList nonDetCmpUnique-     (sortBy nonDetCmpUnique $ scopeUniques scope)-     (sortBy nonDetCmpUnique $ scopeUniques scope')--instance Outputable CmmTickScope where-  ppr GlobalScope     = text "global"-  ppr (SubScope us GlobalScope)-                      = ppr us-  ppr (SubScope us s) = ppr s <> char '/' <> ppr us-  ppr combined        = parens $ hcat $ punctuate (char '+') $-                        map (hcat . punctuate (char '/') . map ppr . reverse) $-                        scopeToPaths combined---- | Checks whether two tick scopes are sub-scopes of each other. True--- if the two scopes are equal.-isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool-isTickSubScope = cmp-  where cmp _              GlobalScope             = True-        cmp GlobalScope    _                       = False-        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'-        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'-        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'---- | Combine two tick scopes. The new scope should be sub-scope of--- both parameters. We simplfy automatically if one tick scope is a--- sub-scope of the other already.-combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope-combineTickScopes s1 s2-  | s1 `isTickSubScope` s2 = s1-  | s2 `isTickSubScope` s1 = s2-  | otherwise              = CombinedScope s1 s2
− compiler/cmm/CmmOpt.hs 
@@ -1,423 +0,0 @@------------------------------------------------------------------------------------ Cmm optimisation------ (c) The University of Glasgow 2006-----------------------------------------------------------------------------------module CmmOpt (-        constantFoldNode,-        constantFoldExpr,-        cmmMachOpFold,-        cmmMachOpFoldM- ) where--import GhcPrelude--import CmmUtils-import Cmm-import DynFlags-import Util--import Outputable-import GHC.Platform--import Data.Bits-import Data.Maybe---constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x-constantFoldNode dflags = mapExp (constantFoldExpr dflags)--constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr-constantFoldExpr dflags = wrapRecExp f-  where f (CmmMachOp op args) = cmmMachOpFold dflags op args-        f (CmmRegOff r 0) = CmmReg r-        f e = e---- -------------------------------------------------------------------------------- MachOp constant folder---- Now, try to constant-fold the MachOps.  The arguments have already--- been optimized and folded.--cmmMachOpFold-    :: DynFlags-    -> MachOp       -- The operation from an CmmMachOp-    -> [CmmExpr]    -- The optimized arguments-    -> CmmExpr--cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)---- Returns Nothing if no changes, useful for Hoopl, also reduces--- allocation!-cmmMachOpFoldM-    :: DynFlags-    -> MachOp-    -> [CmmExpr]-    -> Maybe CmmExpr--cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]-  = Just $ case op of-      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)-      MO_Not _   -> CmmLit (CmmInt (complement x) rep)--        -- these are interesting: we must first narrow to the-        -- "from" type, in order to truncate to the correct size.-        -- The final narrow/widen to the destination type-        -- is implicit in the CmmLit.-      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)-      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)-      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)--      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op----- Eliminate conversion NOPs-cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x-cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x---- Eliminate nested conversions where possible-cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]-  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,-    Just (_,   rep3,signed2) <- isIntConversion conv_outer-  = case () of-        -- widen then narrow to the same size is a nop-      _ | rep1 < rep2 && rep1 == rep3 -> Just x-        -- Widen then narrow to different size: collapse to single conversion-        -- but remember to use the signedness from the widening, just in case-        -- the final conversion is a widen.-        | rep1 < rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]-        -- Nested widenings: collapse if the signedness is the same-        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->-            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]-        -- Nested narrowings: collapse-        | rep1 > rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]-        | otherwise ->-            Nothing-  where-        isIntConversion (MO_UU_Conv rep1 rep2)-          = Just (rep1,rep2,False)-        isIntConversion (MO_SS_Conv rep1 rep2)-          = Just (rep1,rep2,True)-        isIntConversion _ = Nothing--        intconv True  = MO_SS_Conv-        intconv False = MO_UU_Conv---- ToDo: a narrow of a load can be collapsed into a narrow load, right?--- but what if the architecture only supports word-sized loads, should--- we do the transformation anyway?--cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]-  = case mop of-        -- for comparisons: don't forget to narrow the arguments before-        -- comparing, since they might be out of range.-        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))-        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))--        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))-        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))-        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))-        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))--        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))-        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))-        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))-        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))--        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)-        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)-        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)-        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)-        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)-        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)-        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)--        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)-        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)-        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)--        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)-        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)-        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)--        _          -> Nothing--   where-        x_u = narrowU xrep x-        y_u = narrowU xrep y-        x_s = narrowS xrep x-        y_s = narrowS xrep y----- When possible, shift the constants to the right-hand side, so that we--- can match for strength reductions.  Note that the code generator will--- also assume that constants have been shifted to the right when--- possible.--cmmMachOpFoldM dflags op [x@(CmmLit _), y]-   | not (isLit y) && isCommutableMachOp op-   = Just (cmmMachOpFold dflags op [y, x])---- Turn (a+b)+c into a+(b+c) where possible.  Because literals are--- moved to the right, it is more likely that we will find--- opportunities for constant folding when the expression is--- right-associated.------ ToDo: this appears to introduce a quadratic behaviour due to the--- nested cmmMachOpFold.  Can we fix this?------ Why do we check isLit arg1?  If arg1 is a lit, it means that arg2--- is also a lit (otherwise arg1 would be on the right).  If we--- put arg1 on the left of the rearranged expression, we'll get into a--- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...------ Also don't do it if arg1 is PicBaseReg, so that we don't separate the--- PicBaseReg from the corresponding label (or label difference).----cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]-   | mop2 `associates_with` mop1-     && not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])-   where-     MO_Add{} `associates_with` MO_Sub{} = True-     mop1 `associates_with` mop2 =-        mop1 == mop2 && isAssociativeMachOp mop1---- special case: (a - b) + c  ==>  a + (c - b)-cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]-   | not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])---- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)------ this is better because lit+N is a single link-time constant (e.g. a--- CmmLabelOff), so the right-hand expression needs only one--- instruction, whereas the left needs two.  This happens when pointer--- tagging gives us label+offset, and PIC turns the label into--- PicBaseReg + label.----cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]-                          , CmmLit (CmmInt n rep) ]-  | isPicReg pic-  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]-  where off = fromIntegral (narrowS rep n)---- Make a RegOff if we can-cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))-cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))-cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))-cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))---- Fold label(+/-)offset into a CmmLit where possible--cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))-cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))-cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))----- Comparison of literal with widened operand: perform the comparison--- at the smaller width, as long as the literal is within range.---- We can't do the reverse trick, when the operand is narrowed:--- narrowing throws away bits from the operand, there's no way to do--- the same comparison at the larger size.--cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]-  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try-    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],-        -- if the operand is widened:-    Just (rep, signed, narrow_fn) <- maybe_conversion conv,-        -- and this is a comparison operation:-    Just narrow_cmp <- maybe_comparison cmp rep signed,-        -- and the literal fits in the smaller size:-    i == narrow_fn rep i-        -- then we can do the comparison at the smaller size-  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])- where-    maybe_conversion (MO_UU_Conv from to)-        | to > from-        = Just (from, False, narrowU)-    maybe_conversion (MO_SS_Conv from to)-        | to > from-        = Just (from, True, narrowS)--        -- don't attempt to apply this optimisation when the source-        -- is a float; see #1916-    maybe_conversion _ = Nothing--        -- careful (#2080): if the original comparison was signed, but-        -- we were doing an unsigned widen, then we must do an-        -- unsigned comparison at the smaller size.-    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)-    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)-    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)-    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)-    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)-    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)-    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)-    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)-    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)-    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)-    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)-    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)-    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)-    maybe_comparison _ _ _ = Nothing---- We can often do something with constants of 0 and 1 ...--- See Note [Comparison operators]--cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]-  = case mop of-        -- Arithmetic-        MO_Add   _ -> Just x   -- x + 0 = x-        MO_Sub   _ -> Just x   -- x - 0 = x-        MO_Mul   _ -> Just y   -- x * 0 = 0--        -- Logical operations-        MO_And   _ -> Just y   -- x &     0 = 0-        MO_Or    _ -> Just x   -- x |     0 = x-        MO_Xor   _ -> Just x   -- x `xor` 0 = x--        -- Shifts-        MO_Shl   _ -> Just x   -- x << 0 = x-        MO_S_Shr _ -> Just x   -- ditto shift-right-        MO_U_Shr _ -> Just x--        -- Comparisons; these ones are trickier-        -- See Note [Comparison operators]-        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y-        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y-        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y-        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto-        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0-        MO_S_Lt  _ | isComparisonExpr x -> Just zero-        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1-        MO_S_Ge  _ | isComparisonExpr x -> Just one--        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y-        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'-        _ -> Nothing-  where-    zero = CmmLit (CmmInt 0 (wordWidth dflags))-    one  = CmmLit (CmmInt 1 (wordWidth dflags))--cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]-  = case mop of-        -- Arithmetic: x*1 = x, etc-        MO_Mul    _ -> Just x-        MO_S_Quot _ -> Just x-        MO_U_Quot _ -> Just x-        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)-        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)--        -- Comparisons; trickier-        -- See Note [Comparison operators]-        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y-        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y-        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y-        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto-        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0-        MO_S_Gt  _ | isComparisonExpr x -> Just zero-        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1-        MO_S_Le  _ | isComparisonExpr x -> Just one-        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y-        MO_S_Ge  _ | isComparisonExpr x -> Just x-        _ -> Nothing-  where-    zero = CmmLit (CmmInt 0 (wordWidth dflags))-    one  = CmmLit (CmmInt 1 (wordWidth dflags))---- Now look for multiplication/division by powers of 2 (integers).--cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]-  = case mop of-        MO_Mul rep-           | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])-        MO_U_Quot rep-           | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])-        MO_U_Rem rep-           | Just _ <- exactLog2 n ->-                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])-        MO_S_Quot rep-           | Just p <- exactLog2 n,-             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require-                                -- it is a reg.  FIXME: remove this restriction.-                Just (cmmMachOpFold dflags (MO_S_Shr rep)-                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])-        MO_S_Rem rep-           | Just p <- exactLog2 n,-             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require-                                -- it is a reg.  FIXME: remove this restriction.-                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).-                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)-                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.-                Just (cmmMachOpFold dflags (MO_Sub rep)-                    [x, cmmMachOpFold dflags (MO_And rep)-                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])-        _ -> Nothing-  where-    -- In contrast with unsigned integers, for signed ones-    -- shift right is not the same as quot, because it rounds-    -- to minus infinity, whereas quot rounds toward zero.-    -- To fix this up, we add one less than the divisor to the-    -- dividend if it is a negative number.-    ---    -- to avoid a test/jump, we use the following sequence:-    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)-    --      x2 = y & (divisor-1)-    --      result = x + x2-    -- this could be done a bit more simply using conditional moves,-    -- but we're processor independent here.-    ---    -- we optimise the divide by 2 case slightly, generating-    --      x1 = x >> word_size-1  (unsigned)-    --      return = x + x1-    signedQuotRemHelper :: Width -> Integer -> CmmExpr-    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]-      where-        bits = fromIntegral (widthInBits rep) - 1-        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep-        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]-        x2 = if p == 1 then x1 else-             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]---- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x--- Unfortunately this needs a unique supply because x might not be a--- register.  See #2253 (program 6) for an example.----- Anything else is just too hard.--cmmMachOpFoldM _ _ _ = Nothing--{- Note [Comparison operators]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   CmmCondBranch ((x>#y) == 1) t f-we really want to convert to-   CmmCondBranch (x>#y) t f--That's what the constant-folding operations on comparison operators do above.--}----- -------------------------------------------------------------------------------- Utils--isPicReg :: CmmExpr -> Bool-isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True-isPicReg _ = False
− compiler/cmm/CmmParse.y 
@@ -1,1442 +0,0 @@------------------------------------------------------------------------------------ (c) The University of Glasgow, 2004-2012------ Parser for concrete Cmm.-----------------------------------------------------------------------------------{- ------------------------------------------------------------------------------Note [Syntax of .cmm files]--NOTE: You are very much on your own in .cmm.  There is very little-error checking at all:--  * Type errors are detected by the (optional) -dcmm-lint pass, if you-    don't turn this on then a type error will likely result in a panic-    from the native code generator.--  * Passing the wrong number of arguments or arguments of the wrong-    type is not detected.--There are two ways to write .cmm code:-- (1) High-level Cmm code delegates the stack handling to GHC, and-     never explicitly mentions Sp or registers.-- (2) Low-level Cmm manages the stack itself, and must know about-     calling conventions.--Whether you want high-level or low-level Cmm is indicated by the-presence of an argument list on a procedure.  For example:--foo ( gcptr a, bits32 b )-{-  // this is high-level cmm code--  if (b > 0) {-     // we can make tail calls passing arguments:-     jump stg_ap_0_fast(a);-  }--  push (stg_upd_frame_info, a) {-    // stack frames can be explicitly pushed--    (x,y) = call wibble(a,b,3,4);-      // calls pass arguments and return results using the native-      // Haskell calling convention.  The code generator will automatically-      // construct a stack frame and an info table for the continuation.--    return (x,y);-      // we can return multiple values from the current proc-  }-}--bar-{-  // this is low-level cmm code, indicated by the fact that we did not-  // put an argument list on bar.--  x = R1;  // the calling convention is explicit: better be careful-           // that this works on all platforms!--  jump %ENTRY_CODE(Sp(0))-}--Here is a list of rules for high-level and low-level code.  If you-break the rules, you get a panic (for using a high-level construct in-a low-level proc), or wrong code (when using low-level code in a-high-level proc).  This stuff isn't checked! (TODO!)--High-level only:--  - tail-calls with arguments, e.g.-    jump stg_fun (arg1, arg2);--  - function calls:-    (ret1,ret2) = call stg_fun (arg1, arg2);--    This makes a call with the NativeNodeCall convention, and the-    values are returned to the following code using the NativeReturn-    convention.--  - returning:-    return (ret1, ret2)--    These use the NativeReturn convention to return zero or more-    results to the caller.--  - pushing stack frames:-    push (info_ptr, field1, ..., fieldN) { ... statements ... }--  - reserving temporary stack space:--      reserve N = x { ... }--    this reserves an area of size N (words) on the top of the stack,-    and binds its address to x (a local register).  Typically this is-    used for allocating temporary storage for passing to foreign-    functions.--    Note that if you make any native calls or invoke the GC in the-    scope of the reserve block, you are responsible for ensuring that-    the stack you reserved is laid out correctly with an info table.--Low-level only:--  - References to Sp, R1-R8, F1-F4 etc.--    NB. foreign calls may clobber the argument registers R1-R8, F1-F4-    etc., so ensure they are saved into variables around foreign-    calls.--  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp-    directly.--Both high-level and low-level code can use a raw tail-call:--    jump stg_fun [R1,R2]--NB. you *must* specify the list of GlobalRegs that are passed via a-jump, otherwise the register allocator will assume that all the-GlobalRegs are dead at the jump.---Calling Conventions----------------------High-level procedures use the NativeNode calling convention, or the-NativeReturn convention if the 'return' keyword is used (see Stack-Frames below).--Low-level procedures implement their own calling convention, so it can-be anything at all.--If a low-level procedure implements the NativeNode calling convention,-then it can be called by high-level code using an ordinary function-call.  In general this is hard to arrange because the calling-convention depends on the number of physical registers available for-parameter passing, but there are two cases where the calling-convention is platform-independent:-- - Zero arguments.-- - One argument of pointer or non-pointer word type; this is always-   passed in R1 according to the NativeNode convention.-- - Returning a single value; these conventions are fixed and platform-   independent.---Stack Frames---------------A stack frame is written like this:--INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )-               return ( arg1, ..., argM )-{-  ... code ...-}--where field1 ... fieldN are the fields of the stack frame (with types)-arg1...argN are the values returned to the stack frame (with types).-The return values are assumed to be passed according to the-NativeReturn convention.--On entry to the code, the stack frame looks like:--   |----------|-   | fieldN   |-   |   ...    |-   | field1   |-   |----------|-   | info_ptr |-   |----------|-   |  argN    |-   |   ...    | <- Sp--and some of the args may be in registers.--We prepend the code by a copyIn of the args, and assign all the stack-frame fields to their formals.  The initial "arg offset" for stack-layout purposes consists of the whole stack frame plus any args that-might be on the stack.--A tail-call may pass a stack frame to the callee using the following-syntax:--jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)--where info_ptr and field1..fieldN describe the stack frame, and-arg1..argN are the arguments passed to f using the NativeNodeCall-convention. Note if a field is longer than a word (e.g. a D_ on-a 32-bit machine) then the call will push as many words as-necessary to the stack to accommodate it (e.g. 2).-------------------------------------------------------------------------------- -}--{-{-# LANGUAGE TupleSections #-}--module CmmParse ( parseCmmFile ) where--import GhcPrelude--import GHC.StgToCmm.ExtCode-import CmmCallConv-import GHC.StgToCmm.Prof-import GHC.StgToCmm.Heap-import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit-                               , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff-                               , getUpdFrameOff )-import qualified GHC.StgToCmm.Monad as F-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Foreign-import GHC.StgToCmm.Expr-import GHC.StgToCmm.Closure-import GHC.StgToCmm.Layout     hiding (ArgRep(..))-import GHC.StgToCmm.Ticky-import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )-import CoreSyn          ( Tickish(SourceNote) )--import CmmOpt-import MkGraph-import Cmm-import CmmUtils-import CmmSwitch        ( mkSwitchTargets )-import CmmInfo-import BlockId-import CmmLex-import CLabel-import SMRep-import Lexer-import CmmMonad--import CostCentre-import ForeignCall-import Module-import GHC.Platform-import Literal-import Unique-import UniqFM-import SrcLoc-import DynFlags-import ErrUtils-import StringBuffer-import FastString-import Panic-import Constants-import Outputable-import BasicTypes-import Bag              ( emptyBag, unitBag )-import Var--import Control.Monad-import Data.Array-import Data.Char        ( ord )-import System.Exit-import Data.Maybe-import qualified Data.Map as M-import qualified Data.ByteString.Char8 as BS8--#include "HsVersions.h"-}--%expect 0--%token-        ':'     { L _ (CmmT_SpecChar ':') }-        ';'     { L _ (CmmT_SpecChar ';') }-        '{'     { L _ (CmmT_SpecChar '{') }-        '}'     { L _ (CmmT_SpecChar '}') }-        '['     { L _ (CmmT_SpecChar '[') }-        ']'     { L _ (CmmT_SpecChar ']') }-        '('     { L _ (CmmT_SpecChar '(') }-        ')'     { L _ (CmmT_SpecChar ')') }-        '='     { L _ (CmmT_SpecChar '=') }-        '`'     { L _ (CmmT_SpecChar '`') }-        '~'     { L _ (CmmT_SpecChar '~') }-        '/'     { L _ (CmmT_SpecChar '/') }-        '*'     { L _ (CmmT_SpecChar '*') }-        '%'     { L _ (CmmT_SpecChar '%') }-        '-'     { L _ (CmmT_SpecChar '-') }-        '+'     { L _ (CmmT_SpecChar '+') }-        '&'     { L _ (CmmT_SpecChar '&') }-        '^'     { L _ (CmmT_SpecChar '^') }-        '|'     { L _ (CmmT_SpecChar '|') }-        '>'     { L _ (CmmT_SpecChar '>') }-        '<'     { L _ (CmmT_SpecChar '<') }-        ','     { L _ (CmmT_SpecChar ',') }-        '!'     { L _ (CmmT_SpecChar '!') }--        '..'    { L _ (CmmT_DotDot) }-        '::'    { L _ (CmmT_DoubleColon) }-        '>>'    { L _ (CmmT_Shr) }-        '<<'    { L _ (CmmT_Shl) }-        '>='    { L _ (CmmT_Ge) }-        '<='    { L _ (CmmT_Le) }-        '=='    { L _ (CmmT_Eq) }-        '!='    { L _ (CmmT_Ne) }-        '&&'    { L _ (CmmT_BoolAnd) }-        '||'    { L _ (CmmT_BoolOr) }--        'True'  { L _ (CmmT_True ) }-        'False' { L _ (CmmT_False) }-        'likely'{ L _ (CmmT_likely)}--        'CLOSURE'       { L _ (CmmT_CLOSURE) }-        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }-        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }-        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }-        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }-        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }-        'else'          { L _ (CmmT_else) }-        'export'        { L _ (CmmT_export) }-        'section'       { L _ (CmmT_section) }-        'goto'          { L _ (CmmT_goto) }-        'if'            { L _ (CmmT_if) }-        'call'          { L _ (CmmT_call) }-        'jump'          { L _ (CmmT_jump) }-        'foreign'       { L _ (CmmT_foreign) }-        'never'         { L _ (CmmT_never) }-        'prim'          { L _ (CmmT_prim) }-        'reserve'       { L _ (CmmT_reserve) }-        'return'        { L _ (CmmT_return) }-        'returns'       { L _ (CmmT_returns) }-        'import'        { L _ (CmmT_import) }-        'switch'        { L _ (CmmT_switch) }-        'case'          { L _ (CmmT_case) }-        'default'       { L _ (CmmT_default) }-        'push'          { L _ (CmmT_push) }-        'unwind'        { L _ (CmmT_unwind) }-        'bits8'         { L _ (CmmT_bits8) }-        'bits16'        { L _ (CmmT_bits16) }-        'bits32'        { L _ (CmmT_bits32) }-        'bits64'        { L _ (CmmT_bits64) }-        'bits128'       { L _ (CmmT_bits128) }-        'bits256'       { L _ (CmmT_bits256) }-        'bits512'       { L _ (CmmT_bits512) }-        'float32'       { L _ (CmmT_float32) }-        'float64'       { L _ (CmmT_float64) }-        'gcptr'         { L _ (CmmT_gcptr) }--        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }-        NAME            { L _ (CmmT_Name        $$) }-        STRING          { L _ (CmmT_String      $$) }-        INT             { L _ (CmmT_Int         $$) }-        FLOAT           { L _ (CmmT_Float       $$) }--%monad { PD } { >>= } { return }-%lexer { cmmlex } { L _ CmmT_EOF }-%name cmmParse cmm-%tokentype { Located CmmToken }---- C-- operator precedences, taken from the C-- spec-%right '||'     -- non-std extension, called %disjoin in C---%right '&&'     -- non-std extension, called %conjoin in C---%right '!'-%nonassoc '>=' '>' '<=' '<' '!=' '=='-%left '|'-%left '^'-%left '&'-%left '>>' '<<'-%left '-' '+'-%left '/' '*' '%'-%right '~'--%%--cmm     :: { CmmParse () }-        : {- empty -}                   { return () }-        | cmmtop cmm                    { do $1; $2 }--cmmtop  :: { CmmParse () }-        : cmmproc                       { $1 }-        | cmmdata                       { $1 }-        | decl                          { $1 }-        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'-                {% liftP . withThisPackage $ \pkg ->-                   do lits <- sequence $6;-                      staticClosure pkg $3 $5 (map getLit lits) }---- The only static closures in the RTS are dummy closures like--- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need--- to provide the full generality of static closures here.--- In particular:---      * CCS can always be CCS_DONT_CARE---      * closure is always extern---      * payload is always empty---      * we can derive closure and info table labels from a single NAME--cmmdata :: { CmmParse () }-        : 'section' STRING '{' data_label statics '}'-                { do lbl <- $4;-                     ss <- sequence $5;-                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }--data_label :: { CmmParse CLabel }-    : NAME ':'-                {% liftP . withThisPackage $ \pkg ->-                   return (mkCmmDataLabel pkg $1) }--statics :: { [CmmParse [CmmStatic]] }-        : {- empty -}                   { [] }-        | static statics                { $1 : $2 }--static  :: { CmmParse [CmmStatic] }-        : type expr ';' { do e <- $2;-                             return [CmmStaticLit (getLit e)] }-        | type ';'                      { return [CmmUninitialised-                                                        (widthInBytes (typeWidth $1))] }-        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised-                                                        (fromIntegral $3)] }-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised-                                                (widthInBytes (typeWidth $1) *-                                                        fromIntegral $3)] }-        | 'CLOSURE' '(' NAME lits ')'-                { do { lits <- sequence $4-                ; dflags <- getDynFlags-                     ; return $ map CmmStaticLit $-                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)-                         -- mkForeignLabel because these are only used-                         -- for CHARLIKE and INTLIKE closures in the RTS.-                        dontCareCCS (map getLit lits) [] [] [] } }-        -- arrays of closures required for the CHARLIKE & INTLIKE arrays--lits    :: { [CmmParse CmmExpr] }-        : {- empty -}           { [] }-        | ',' expr lits         { $2 : $3 }--cmmproc :: { CmmParse () }-        : info maybe_conv maybe_formals maybe_body-                { do ((entry_ret_label, info, stk_formals, formals), agraph) <--                       getCodeScoped $ loopDecls $ do {-                         (entry_ret_label, info, stk_formals) <- $1;-                         dflags <- getDynFlags;-                         formals <- sequence (fromMaybe [] $3);-                         withName (showSDoc dflags (ppr entry_ret_label))-                           $4;-                         return (entry_ret_label, info, stk_formals, formals) }-                     let do_layout = isJust $3-                     code (emitProcWithStackFrame $2 info-                                entry_ret_label stk_formals formals agraph-                                do_layout ) }--maybe_conv :: { Convention }-           : {- empty -}        { NativeNodeCall }-           | 'return'           { NativeReturn }--maybe_body :: { CmmParse () }-           : ';'                { return () }-           | '{' body '}'       { withSourceNote $1 $3 $2 }--info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }-        : NAME-                {% liftP . withThisPackage $ \pkg ->-                   do   newFunctionName $1 pkg-                        return (mkCmmCodeLabel pkg $1, Nothing, []) }---        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'-                -- ptrs, nptrs, closure type, description, type-                {% liftP . withThisPackage $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $11 $13-                          rep  = mkRTSRep (fromIntegral $9) $-                                   mkHeapRep dflags False (fromIntegral $5)-                                                   (fromIntegral $7) Thunk-                              -- not really Thunk, but that makes the info table-                              -- we want.-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }--        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'-                -- ptrs, nptrs, closure type, description, type, fun type-                {% liftP . withThisPackage $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $11 $13-                          ty   = Fun 0 (ArgSpec (fromIntegral $15))-                                -- Arity zero, arg_type $15-                          rep = mkRTSRep (fromIntegral $9) $-                                    mkHeapRep dflags False (fromIntegral $5)-                                                    (fromIntegral $7) ty-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }-                -- we leave most of the fields zero here.  This is only used-                -- to generate the BCO info table in the RTS at the moment.--        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'-                -- ptrs, nptrs, tag, closure type, description, type-                {% liftP . withThisPackage $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $13 $15-                          ty  = Constr (fromIntegral $9)  -- Tag-                                       (BS8.pack $13)-                          rep = mkRTSRep (fromIntegral $11) $-                                  mkHeapRep dflags False (fromIntegral $5)-                                                  (fromIntegral $7) ty-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },-                              []) }--                     -- If profiling is on, this string gets duplicated,-                     -- but that's the way the old code did it we can fix it some other time.--        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'-                -- selector, closure type, description, type-                {% liftP . withThisPackage $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $9 $11-                          ty  = ThunkSelector (fromIntegral $5)-                          rep = mkRTSRep (fromIntegral $7) $-                                   mkHeapRep dflags False 0 0 ty-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }--        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'-                -- closure type (no live regs)-                {% liftP . withThisPackage $ \pkg ->-                   do let prof = NoProfilingInfo-                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []-                      return (mkCmmRetLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }--        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'-                -- closure type, live regs-                {% liftP . withThisPackage $ \pkg ->-                   do dflags <- getDynFlags-                      live <- sequence $7-                      let prof = NoProfilingInfo-                          -- drop one for the info pointer-                          bitmap = mkLiveness dflags (drop 1 live)-                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap-                      return (mkCmmRetLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              live) }--body    :: { CmmParse () }-        : {- empty -}                   { return () }-        | decl body                     { do $1; $2 }-        | stmt body                     { do $1; $2 }--decl    :: { CmmParse () }-        : type names ';'                { mapM_ (newLocal $1) $2 }-        | 'import' importNames ';'      { mapM_ newImport $2 }-        | 'export' names ';'            { return () }  -- ignore exports----- an imported function name, with optional packageId-importNames-        :: { [(FastString, CLabel)] }-        : importName                    { [$1] }-        | importName ',' importNames    { $1 : $3 }--importName-        :: { (FastString,  CLabel) }--        -- A label imported without an explicit packageId.-        --      These are taken to come from some foreign, unnamed package.-        : NAME-        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }--        -- as previous 'NAME', but 'IsData'-        | 'CLOSURE' NAME-        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }--        -- A label imported with an explicit packageId.-        | STRING NAME-        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }---names   :: { [FastString] }-        : NAME                          { [$1] }-        | NAME ',' names                { $1 : $3 }--stmt    :: { CmmParse () }-        : ';'                                   { return () }--        | NAME ':'-                { do l <- newLabel $1; emitLabel l }----        | lreg '=' expr ';'-                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }-        | type '[' expr ']' '=' expr ';'-                { withSourceNote $2 $7 (doStore $1 $3 $6) }--        -- Gah! We really want to say "foreign_results" but that causes-        -- a shift/reduce conflict with assignment.  We either-        -- we expand out the no-result and single result cases or-        -- we tweak the syntax to avoid the conflict.  The later-        -- option is taken here because the other way would require-        -- multiple levels of expanding and get unwieldy.-        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'-                {% foreignCall $3 $1 $4 $6 $8 $9 }-        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'-                {% primCall $1 $4 $6 }-        -- stmt-level macros, stealing syntax from ordinary C-- function calls.-        -- Perhaps we ought to use the %%-form?-        | NAME '(' exprs0 ')' ';'-                {% stmtMacro $1 $3  }-        | 'switch' maybe_range expr '{' arms default '}'-                { do as <- sequence $5; doSwitch $2 $3 as $6 }-        | 'goto' NAME ';'-                { do l <- lookupLabel $2; emit (mkBranch l) }-        | 'return' '(' exprs0 ')' ';'-                { doReturn $3 }-        | 'jump' expr vols ';'-                { doRawJump $2 $3 }-        | 'jump' expr '(' exprs0 ')' ';'-                { doJumpWithStack $2 [] $4 }-        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'-                { doJumpWithStack $2 $4 $7 }-        | 'call' expr '(' exprs0 ')' ';'-                { doCall $2 [] $4 }-        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'-                { doCall $6 $2 $8 }-        | 'if' bool_expr cond_likely 'goto' NAME-                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }-        | 'if' bool_expr cond_likely '{' body '}' else-                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }-        | 'push' '(' exprs0 ')' maybe_body-                { pushStackFrame $3 $5 }-        | 'reserve' expr '=' lreg maybe_body-                { reserveStackFrame $2 $4 $5 }-        | 'unwind' unwind_regs ';'-                { $2 >>= code . emitUnwind }--unwind_regs-        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }-        : GLOBALREG '=' expr_or_unknown ',' unwind_regs-                { do e <- $3; rest <- $5; return (($1, e) : rest) }-        | GLOBALREG '=' expr_or_unknown-                { do e <- $3; return [($1, e)] }---- | Used by unwind to indicate unknown unwinding values.-expr_or_unknown-        :: { CmmParse (Maybe CmmExpr) }-        : 'return'-                { do return Nothing }-        | expr-                { do e <- $1; return (Just e) }--foreignLabel     :: { CmmParse CmmExpr }-        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }--opt_never_returns :: { CmmReturnInfo }-        :                               { CmmMayReturn }-        | 'never' 'returns'             { CmmNeverReturns }--bool_expr :: { CmmParse BoolExpr }-        : bool_op                       { $1 }-        | expr                          { do e <- $1; return (BoolTest e) }--bool_op :: { CmmParse BoolExpr }-        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;-                                          return (BoolAnd e1 e2) }-        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;-                                          return (BoolOr e1 e2)  }-        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }-        | '(' bool_op ')'               { $2 }--safety  :: { Safety }-        : {- empty -}                   { PlayRisky }-        | STRING                        {% parseSafety $1 }--vols    :: { [GlobalReg] }-        : '[' ']'                       { [] }-        | '[' '*' ']'                   {% do df <- getDynFlags-                                         ; return (realArgRegsCover df) }-                                           -- All of them. See comment attached-                                           -- to realArgRegsCover-        | '[' globals ']'               { $2 }--globals :: { [GlobalReg] }-        : GLOBALREG                     { [$1] }-        | GLOBALREG ',' globals         { $1 : $3 }--maybe_range :: { Maybe (Integer,Integer) }-        : '[' INT '..' INT ']'  { Just ($2, $4) }-        | {- empty -}           { Nothing }--arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }-        : {- empty -}                   { [] }-        | arm arms                      { $1 : $2 }--arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }-        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }--arm_body :: { CmmParse (Either BlockId (CmmParse ())) }-        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }-        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }--ints    :: { [Integer] }-        : INT                           { [ $1 ] }-        | INT ',' ints                  { $1 : $3 }--default :: { Maybe (CmmParse ()) }-        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }-        -- taking a few liberties with the C-- syntax here; C-- doesn't have-        -- 'default' branches-        | {- empty -}                   { Nothing }---- Note: OldCmm doesn't support a first class 'else' statement, though--- CmmNode does.-else    :: { CmmParse () }-        : {- empty -}                   { return () }-        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }--cond_likely :: { Maybe Bool }-        : '(' 'likely' ':' 'True'  ')'  { Just True  }-        | '(' 'likely' ':' 'False' ')'  { Just False }-        | {- empty -}                   { Nothing }----- we have to write this out longhand so that Happy's precedence rules--- can kick in.-expr    :: { CmmParse CmmExpr }-        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }-        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }-        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }-        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }-        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }-        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }-        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }-        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }-        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }-        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }-        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }-        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }-        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }-        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }-        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }-        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }-        | '~' expr                      { mkMachOp MO_Not [$2] }-        | '-' expr                      { mkMachOp MO_S_Neg [$2] }-        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;-                                                return (mkMachOp mo [$1,$5]) } }-        | expr0                         { $1 }--expr0   :: { CmmParse CmmExpr }-        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }-        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }-        | STRING                 { do s <- code (newStringCLit $1);-                                      return (CmmLit s) }-        | reg                    { $1 }-        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }-        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }-        | '(' expr ')'           { $2 }----- leaving out the type of a literal gives you the native word size in C---maybe_ty :: { CmmType }-        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }-        | '::' type                     { $2 }--cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }-        : {- empty -}                   { [] }-        | cmm_hint_exprs                { $1 }--cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }-        : cmm_hint_expr                 { [$1] }-        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }--cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }-        : expr                          { do e <- $1;-                                             return (e, inferCmmHint e) }-        | expr STRING                   {% do h <- parseCmmHint $2;-                                              return $ do-                                                e <- $1; return (e, h) }--exprs0  :: { [CmmParse CmmExpr] }-        : {- empty -}                   { [] }-        | exprs                         { $1 }--exprs   :: { [CmmParse CmmExpr] }-        : expr                          { [ $1 ] }-        | expr ',' exprs                { $1 : $3 }--reg     :: { CmmParse CmmExpr }-        : NAME                  { lookupName $1 }-        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }--foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }-        : {- empty -}                   { [] }-        | '(' foreign_formals ')' '='   { $2 }--foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }-        : foreign_formal                        { [$1] }-        | foreign_formal ','                    { [$1] }-        | foreign_formal ',' foreign_formals    { $1 : $3 }--foreign_formal :: { CmmParse (LocalReg, ForeignHint) }-        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }-        | STRING local_lreg     {% do h <- parseCmmHint $1;-                                      return $ do-                                         e <- $2; return (e,h) }--local_lreg :: { CmmParse LocalReg }-        : NAME                  { do e <- lookupName $1;-                                     return $-                                       case e of-                                        CmmReg (CmmLocal r) -> r-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }--lreg    :: { CmmParse CmmReg }-        : NAME                  { do e <- lookupName $1;-                                     return $-                                       case e of-                                        CmmReg r -> r-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }-        | GLOBALREG             { return (CmmGlobal $1) }--maybe_formals :: { Maybe [CmmParse LocalReg] }-        : {- empty -}           { Nothing }-        | '(' formals0 ')'      { Just $2 }--formals0 :: { [CmmParse LocalReg] }-        : {- empty -}           { [] }-        | formals               { $1 }--formals :: { [CmmParse LocalReg] }-        : formal ','            { [$1] }-        | formal                { [$1] }-        | formal ',' formals       { $1 : $3 }--formal :: { CmmParse LocalReg }-        : type NAME             { newLocal $1 $2 }--type    :: { CmmType }-        : 'bits8'               { b8 }-        | typenot8              { $1 }--typenot8 :: { CmmType }-        : 'bits16'              { b16 }-        | 'bits32'              { b32 }-        | 'bits64'              { b64 }-        | 'bits128'             { b128 }-        | 'bits256'             { b256 }-        | 'bits512'             { b512 }-        | 'float32'             { f32 }-        | 'float64'             { f64 }-        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }--{-section :: String -> SectionType-section "text"      = Text-section "data"      = Data-section "rodata"    = ReadOnlyData-section "relrodata" = RelocatableReadOnlyData-section "bss"       = UninitialisedData-section s           = OtherSection s--mkString :: String -> CmmStatic-mkString s = CmmString (BS8.pack s)---- |--- Given an info table, decide what the entry convention for the proc--- is.  That is, for an INFO_TABLE_RET we want the return convention,--- otherwise it is a NativeNodeCall.----infoConv :: Maybe CmmInfoTable -> Convention-infoConv Nothing = NativeNodeCall-infoConv (Just info)-  | isStackRep (cit_rep info) = NativeReturn-  | otherwise                 = NativeNodeCall---- mkMachOp infers the type of the MachOp from the type of its first--- argument.  We assume that this is correct: for MachOps that don't have--- symmetrical args (e.g. shift ops), the first arg determines the type of--- the op.-mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr-mkMachOp fn args = do-  dflags <- getDynFlags-  arg_exprs <- sequence args-  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)--getLit :: CmmExpr -> CmmLit-getLit (CmmLit l) = l-getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r-getLit _ = panic "invalid literal" -- TODO messy failure--nameToMachOp :: FastString -> PD (Width -> MachOp)-nameToMachOp name =-  case lookupUFM machOps name of-        Nothing -> fail ("unknown primitive " ++ unpackFS name)-        Just m  -> return m--exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)-exprOp name args_code = do-  dflags <- getDynFlags-  case lookupUFM (exprMacros dflags) name of-     Just f  -> return $ do-        args <- sequence args_code-        return (f args)-     Nothing -> do-        mo <- nameToMachOp name-        return $ mkMachOp mo args_code--exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)-exprMacros dflags = listToUFM [-  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),-  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),-  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),-  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),-  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),-  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),-  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),-  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )-  ]---- we understand a subset of C-- primitives:-machOps = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "add",        MO_Add ),-        ( "sub",        MO_Sub ),-        ( "eq",         MO_Eq ),-        ( "ne",         MO_Ne ),-        ( "mul",        MO_Mul ),-        ( "neg",        MO_S_Neg ),-        ( "quot",       MO_S_Quot ),-        ( "rem",        MO_S_Rem ),-        ( "divu",       MO_U_Quot ),-        ( "modu",       MO_U_Rem ),--        ( "ge",         MO_S_Ge ),-        ( "le",         MO_S_Le ),-        ( "gt",         MO_S_Gt ),-        ( "lt",         MO_S_Lt ),--        ( "geu",        MO_U_Ge ),-        ( "leu",        MO_U_Le ),-        ( "gtu",        MO_U_Gt ),-        ( "ltu",        MO_U_Lt ),--        ( "and",        MO_And ),-        ( "or",         MO_Or ),-        ( "xor",        MO_Xor ),-        ( "com",        MO_Not ),-        ( "shl",        MO_Shl ),-        ( "shrl",       MO_U_Shr ),-        ( "shra",       MO_S_Shr ),--        ( "fadd",       MO_F_Add ),-        ( "fsub",       MO_F_Sub ),-        ( "fneg",       MO_F_Neg ),-        ( "fmul",       MO_F_Mul ),-        ( "fquot",      MO_F_Quot ),--        ( "feq",        MO_F_Eq ),-        ( "fne",        MO_F_Ne ),-        ( "fge",        MO_F_Ge ),-        ( "fle",        MO_F_Le ),-        ( "fgt",        MO_F_Gt ),-        ( "flt",        MO_F_Lt ),--        ( "lobits8",  flip MO_UU_Conv W8  ),-        ( "lobits16", flip MO_UU_Conv W16 ),-        ( "lobits32", flip MO_UU_Conv W32 ),-        ( "lobits64", flip MO_UU_Conv W64 ),--        ( "zx16",     flip MO_UU_Conv W16 ),-        ( "zx32",     flip MO_UU_Conv W32 ),-        ( "zx64",     flip MO_UU_Conv W64 ),--        ( "sx16",     flip MO_SS_Conv W16 ),-        ( "sx32",     flip MO_SS_Conv W32 ),-        ( "sx64",     flip MO_SS_Conv W64 ),--        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode-        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode-        ( "f2i8",     flip MO_FS_Conv W8 ),-        ( "f2i16",    flip MO_FS_Conv W16 ),-        ( "f2i32",    flip MO_FS_Conv W32 ),-        ( "f2i64",    flip MO_FS_Conv W64 ),-        ( "i2f32",    flip MO_SF_Conv W32 ),-        ( "i2f64",    flip MO_SF_Conv W64 )-        ]--callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))-callishMachOps = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "read_barrier", (MO_ReadBarrier,)),-        ( "write_barrier", (MO_WriteBarrier,)),-        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),-        ( "memset", memcpyLikeTweakArgs MO_Memset ),-        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),-        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),--        ("prefetch0", (MO_Prefetch_Data 0,)),-        ("prefetch1", (MO_Prefetch_Data 1,)),-        ("prefetch2", (MO_Prefetch_Data 2,)),-        ("prefetch3", (MO_Prefetch_Data 3,)),--        ( "popcnt8",  (MO_PopCnt W8,)),-        ( "popcnt16", (MO_PopCnt W16,)),-        ( "popcnt32", (MO_PopCnt W32,)),-        ( "popcnt64", (MO_PopCnt W64,)),--        ( "pdep8",  (MO_Pdep W8,)),-        ( "pdep16", (MO_Pdep W16,)),-        ( "pdep32", (MO_Pdep W32,)),-        ( "pdep64", (MO_Pdep W64,)),--        ( "pext8",  (MO_Pext W8,)),-        ( "pext16", (MO_Pext W16,)),-        ( "pext32", (MO_Pext W32,)),-        ( "pext64", (MO_Pext W64,)),--        ( "cmpxchg8",  (MO_Cmpxchg W8,)),-        ( "cmpxchg16", (MO_Cmpxchg W16,)),-        ( "cmpxchg32", (MO_Cmpxchg W32,)),-        ( "cmpxchg64", (MO_Cmpxchg W64,))--        -- ToDo: the rest, maybe-        -- edit: which rest?-        -- also: how do we tell CMM Lint how to type check callish macops?-    ]-  where-    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])-    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"-    memcpyLikeTweakArgs op args@(_:_) =-        (op align, args')-      where-        args' = init args-        align = case last args of-          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger-          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)-        -- The alignment of memcpy-ish operations must be a-        -- compile-time constant. We verify this here, passing it around-        -- in the MO_* constructor. In order to do this, however, we-        -- must intercept the arguments in primCall.--parseSafety :: String -> PD Safety-parseSafety "safe"   = return PlaySafe-parseSafety "unsafe" = return PlayRisky-parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = fail ("unrecognised safety: " ++ str)--parseCmmHint :: String -> PD ForeignHint-parseCmmHint "ptr"    = return AddrHint-parseCmmHint "signed" = return SignedHint-parseCmmHint str      = fail ("unrecognised hint: " ++ str)---- labels are always pointers, so we might as well infer the hint-inferCmmHint :: CmmExpr -> ForeignHint-inferCmmHint (CmmLit (CmmLabel _)) = AddrHint-inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint-inferCmmHint _ = NoHint--isPtrGlobalReg Sp                    = True-isPtrGlobalReg SpLim                 = True-isPtrGlobalReg Hp                    = True-isPtrGlobalReg HpLim                 = True-isPtrGlobalReg CCCS                  = True-isPtrGlobalReg CurrentTSO            = True-isPtrGlobalReg CurrentNursery        = True-isPtrGlobalReg (VanillaReg _ VGcPtr) = True-isPtrGlobalReg _                     = False--happyError :: PD a-happyError = PD $ \_ s -> unP srcParseFail s---- -------------------------------------------------------------------------------- Statement-level macros--stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())-stmtMacro fun args_code = do-  case lookupUFM stmtMacros fun of-    Nothing -> fail ("unknown macro: " ++ unpackFS fun)-    Just fcode -> return $ do-        args <- sequence args_code-        code (fcode args)--stmtMacros :: UniqFM ([CmmExpr] -> FCode ())-stmtMacros = listToUFM [-  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),-  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),--  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),-  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),--  -- completely generic heap and stack checks, for use in high-level cmm.-  ( fsLit "HP_CHK_GEN",            \[bytes] ->-                                      heapStackCheckGen Nothing (Just bytes) ),-  ( fsLit "STK_CHK_GEN",           \[] ->-                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),--  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but-  -- we use the stack for a bit of temporary storage in a couple of primops-  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->-                                      heapStackCheckGen (Just bytes) Nothing ),--  -- A stack check on entry to a thunk, where the argument is the thunk pointer.-  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),--  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),-  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),--  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),-  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),--  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),-  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->-                                        emitSetDynHdr ptr info ccs ),-  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->-                                        tickyAllocPrim hdr goods slop ),-  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->-                                        tickyAllocPAP goods slop ),-  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->-                                        tickyAllocThunk goods slop ),-  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )- ]--emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()-emitPushUpdateFrame sp e = do-  dflags <- getDynFlags-  emitUpdateFrame dflags sp mkUpdInfoLabel e--pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()-pushStackFrame fields body = do-  dflags <- getDynFlags-  exprs <- sequence fields-  updfr_off <- getUpdFrameOff-  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old-                                           [] updfr_off exprs-  emit g-  withUpdFrameOff new_updfr_off body--reserveStackFrame-  :: CmmParse CmmExpr-  -> CmmParse CmmReg-  -> CmmParse ()-  -> CmmParse ()-reserveStackFrame psize preg body = do-  dflags <- getDynFlags-  old_updfr_off <- getUpdFrameOff-  reg <- preg-  esize <- psize-  let size = case constantFoldExpr dflags esize of-               CmmLit (CmmInt n _) -> n-               _other -> pprPanic "CmmParse: not a compile-time integer: "-                            (ppr esize)-  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size-  emitAssign reg (CmmStackSlot Old frame)-  withUpdFrameOff frame body--profilingInfo dflags desc_str ty_str-  = if not (gopt Opt_SccProfilingOn dflags)-    then NoProfilingInfo-    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)--staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()-staticClosure pkg cl_label info payload-  = do dflags <- getDynFlags-       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []-       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits--foreignCall-        :: String-        -> [CmmParse (LocalReg, ForeignHint)]-        -> CmmParse CmmExpr-        -> [CmmParse (CmmExpr, ForeignHint)]-        -> Safety-        -> CmmReturnInfo-        -> PD (CmmParse ())-foreignCall conv_string results_code expr_code args_code safety ret-  = do  conv <- case conv_string of-          "C" -> return CCallConv-          "stdcall" -> return StdCallConv-          _ -> fail ("unknown calling convention: " ++ conv_string)-        return $ do-          dflags <- getDynFlags-          results <- sequence results_code-          expr <- expr_code-          args <- sequence args_code-          let-                  expr' = adjCallTarget dflags conv expr args-                  (arg_exprs, arg_hints) = unzip args-                  (res_regs,  res_hints) = unzip results-                  fc = ForeignConvention conv arg_hints res_hints ret-                  target = ForeignTarget expr' fc-          _ <- code $ emitForeignCall safety res_regs target arg_exprs-          return ()---doReturn :: [CmmParse CmmExpr] -> CmmParse ()-doReturn exprs_code = do-  dflags <- getDynFlags-  exprs <- sequence exprs_code-  updfr_off <- getUpdFrameOff-  emit (mkReturnSimple dflags exprs updfr_off)--mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph-mkReturnSimple dflags actuals updfr_off =-  mkReturn dflags e actuals updfr_off-  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)-                             (gcWord dflags))--doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()-doRawJump expr_code vols = do-  dflags <- getDynFlags-  expr <- expr_code-  updfr_off <- getUpdFrameOff-  emit (mkRawJump dflags expr updfr_off vols)--doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]-                -> [CmmParse CmmExpr] -> CmmParse ()-doJumpWithStack expr_code stk_code args_code = do-  dflags <- getDynFlags-  expr <- expr_code-  stk_args <- sequence stk_code-  args <- sequence args_code-  updfr_off <- getUpdFrameOff-  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)--doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]-       -> CmmParse ()-doCall expr_code res_code args_code = do-  dflags <- getDynFlags-  expr <- expr_code-  args <- sequence args_code-  ress <- sequence res_code-  updfr_off <- getUpdFrameOff-  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []-  emit c--adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]-              -> CmmExpr--- On Windows, we have to add the '@N' suffix to the label when making--- a call with the stdcall calling convention.-adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args- | platformOS (targetPlatform dflags) == OSMinGW32-  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))-  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))-                 -- c.f. CgForeignCall.emitForeignCall-adjCallTarget _ _ expr _-  = expr--primCall-        :: [CmmParse (CmmFormal, ForeignHint)]-        -> FastString-        -> [CmmParse CmmExpr]-        -> PD (CmmParse ())-primCall results_code name args_code-  = case lookupUFM callishMachOps name of-        Nothing -> fail ("unknown primitive " ++ unpackFS name)-        Just f  -> return $ do-                results <- sequence results_code-                args <- sequence args_code-                let (p, args') = f args-                code (emitPrimCall (map fst results) p args')--doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()-doStore rep addr_code val_code-  = do dflags <- getDynFlags-       addr <- addr_code-       val <- val_code-        -- if the specified store type does not match the type of the expr-        -- on the rhs, then we insert a coercion that will cause the type-        -- mismatch to be flagged by cmm-lint.  If we don't do this, then-        -- the store will happen at the wrong type, and the error will not-        -- be noticed.-       let val_width = typeWidth (cmmExprType dflags val)-           rep_width = typeWidth rep-       let coerce_val-                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]-                | otherwise              = val-       emitStore addr coerce_val---- -------------------------------------------------------------------------------- If-then-else and boolean expressions--data BoolExpr-  = BoolExpr `BoolAnd` BoolExpr-  | BoolExpr `BoolOr`  BoolExpr-  | BoolNot BoolExpr-  | BoolTest CmmExpr---- ToDo: smart constructors which simplify the boolean expression.--cmmIfThenElse cond then_part else_part likely = do-     then_id <- newBlockId-     join_id <- newBlockId-     c <- cond-     emitCond c then_id likely-     else_part-     emit (mkBranch join_id)-     emitLabel then_id-     then_part-     -- fall through to join-     emitLabel join_id--cmmRawIf cond then_id likely = do-    c <- cond-    emitCond c then_id likely---- 'emitCond cond true_id'  emits code to test whether the cond is true,--- branching to true_id if so, and falling through otherwise.-emitCond (BoolTest e) then_id likely = do-  else_id <- newBlockId-  emit (mkCbranch e then_id else_id likely)-  emitLabel else_id-emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely-  | Just op' <- maybeInvertComparison op-  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)-emitCond (BoolNot e) then_id likely = do-  else_id <- newBlockId-  emitCond e else_id likely-  emit (mkBranch then_id)-  emitLabel else_id-emitCond (e1 `BoolOr` e2) then_id likely = do-  emitCond e1 then_id likely-  emitCond e2 then_id likely-emitCond (e1 `BoolAnd` e2) then_id likely = do-        -- we'd like to invert one of the conditionals here to avoid an-        -- extra branch instruction, but we can't use maybeInvertComparison-        -- here because we can't look too closely at the expression since-        -- we're in a loop.-  and_id <- newBlockId-  else_id <- newBlockId-  emitCond e1 and_id likely-  emit (mkBranch else_id)-  emitLabel and_id-  emitCond e2 then_id likely-  emitLabel else_id---- -------------------------------------------------------------------------------- Source code notes---- | Generate a source note spanning from "a" to "b" (inclusive), then--- proceed with parsing. This allows debugging tools to reason about--- locations in Cmm code.-withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c-withSourceNote a b parse = do-  name <- getName-  case combineSrcSpans (getLoc a) (getLoc b) of-    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse-    _other           -> parse---- -------------------------------------------------------------------------------- Table jumps---- We use a simplified form of C-- switch statements for now.  A--- switch statement always compiles to a table jump.  Each arm can--- specify a list of values (not ranges), and there can be a single--- default branch.  The range of the table is given either by the--- optional range on the switch (eg. switch [0..7] {...}), or by--- the minimum/maximum values from the branches.--doSwitch :: Maybe (Integer,Integer)-         -> CmmParse CmmExpr-         -> [([Integer],Either BlockId (CmmParse ()))]-         -> Maybe (CmmParse ()) -> CmmParse ()-doSwitch mb_range scrut arms deflt-   = do-        -- Compile code for the default branch-        dflt_entry <--                case deflt of-                  Nothing -> return Nothing-                  Just e  -> do b <- forkLabelledCode e; return (Just b)--        -- Compile each case branch-        table_entries <- mapM emitArm arms-        let table = M.fromList (concat table_entries)--        dflags <- getDynFlags-        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range--        expr <- scrut-        -- ToDo: check for out of range and jump to default if necessary-        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)-   where-        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]-        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]-        emitArm (ints,Right code) = do-           blockid <- forkLabelledCode code-           return [ (i,blockid) | i <- ints ]--forkLabelledCode :: CmmParse () -> CmmParse BlockId-forkLabelledCode p = do-  (_,ag) <- getCodeScoped p-  l <- newBlockId-  emitOutOfLine l ag-  return l---- -------------------------------------------------------------------------------- Putting it all together---- The initial environment: we define some constants that the compiler--- knows about here.-initEnv :: DynFlags -> Env-initEnv dflags = listToUFM [-  ( fsLit "SIZEOF_StgHeader",-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),-  ( fsLit "SIZEOF_StgInfoTable",-    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))-  ]--parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)-parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do-  buf <- hGetStringBuffer filename-  let-        init_loc = mkRealSrcLoc (mkFastString filename) 1 1-        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }-                -- reset the lex_state: the Lexer monad leaves some stuff-                -- in there we don't want.-  case unPD cmmParse dflags init_state of-    PFailed pst ->-        return (getMessages pst dflags, Nothing)-    POk pst code -> do-        st <- initC-        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()-            (cmm,_) = runC dflags no_module st fcode-        let ms = getMessages pst dflags-        if (errorsFound dflags ms)-         then return (ms, Nothing)-         else return (ms, Just cmm)-  where-        no_module = panic "parseCmmFile: no module"-}
− compiler/cmm/CmmPipeline.hs 
@@ -1,367 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module CmmPipeline (-  -- | Converts C-- with an implicit stack and native C-- calls into-  -- optimized, CPS converted and native-call-less C--.  The latter-  -- C-- can be used to generate assembly.-  cmmPipeline-) where--import GhcPrelude--import Cmm-import CmmLint-import CmmBuildInfoTables-import CmmCommonBlockElim-import CmmImplementSwitchPlans-import CmmProcPoint-import CmmContFlowOpt-import CmmLayoutStack-import CmmSink-import Hoopl.Collections--import UniqSupply-import DynFlags-import ErrUtils-import HscTypes-import Control.Monad-import Outputable-import GHC.Platform---------------------------------------------------------------------------------- | Top level driver for C-- pipeline--------------------------------------------------------------------------------cmmPipeline- :: HscEnv -- Compilation env including-           -- dynamic flags: -dcmm-lint -ddump-cmm-cps- -> ModuleSRTInfo        -- Info about SRTs generated so far- -> CmmGroup             -- Input C-- with Procedures- -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C----cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $-  do let dflags = hsc_dflags hsc_env--     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog--     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops-     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)--     return (srtInfo, cmms)--  where forceRes (info, group) =-          info `seq` foldr (\decl r -> decl `seq` r) () group--        dflags = hsc_dflags hsc_env--cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])-cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])-cpsTop hsc_env proc =-    do-       ----------- Control-flow optimisations ------------------------------------       -- The first round of control-flow optimisation speeds up the-       -- later passes by removing lots of empty blocks, so we do it-       -- even when optimisation isn't turned on.-       ---       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}-            return $ cmmCfgOptsProc splitting_proc_points proc-       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g--       let !TopInfo {stack_info=StackInfo { arg_space = entry_off-                                          , do_layout = do_layout }} = h--       ----------- Eliminate common blocks --------------------------------------       g <- {-# SCC "elimCommonBlocks" #-}-            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g-                          Opt_D_dump_cmm_cbe "Post common block elimination"--       -- Any work storing block Labels must be performed _after_-       -- elimCommonBlocks--       ----------- Implement switches -------------------------------------------       g <- {-# SCC "createSwitchPlans" #-}-            runUniqSM $ cmmImplementSwitchPlans dflags g-       dump Opt_D_dump_cmm_switch "Post switch plan" g--       ----------- Proc points --------------------------------------------------       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g-       proc_points <--          if splitting_proc_points-             then do-               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $-                  minimalProcPointSet (targetPlatform dflags) call_pps g-               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"-                     FormatCMM (ppr l $$ ppr pp $$ ppr g)-               return pp-             else-               return call_pps--       ----------- Layout the stack and manifest Sp -----------------------------       (g, stackmaps) <--            {-# SCC "layoutStack" #-}-            if do_layout-               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g-               else return (g, mapEmpty)-       dump Opt_D_dump_cmm_sp "Layout Stack" g--       ----------- Sink and inline assignments  ---------------------------------       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]-            condPass Opt_CmmSink (cmmSink dflags) g-                     Opt_D_dump_cmm_sink "Sink assignments"--       ------------- CAF analysis -----------------------------------------------       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g-       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)--       g <- if splitting_proc_points-            then do-               ------------- Split into separate procedures ------------------------               let pp_map = {-# SCC "procPointAnalysis" #-}-                            procPointAnalysis proc_points g-               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"-                  FormatCMM (ppr pp_map)-               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $-                    splitAtProcPoints dflags l call_pps proc_points pp_map-                                      (CmmProc h l v g)-               dumps Opt_D_dump_cmm_split "Post splitting" g-               return g-             else do-               -- attach info tables to return points-               return $ [attachContInfoTables call_pps (CmmProc h l v g)]--       ------------- Populate info tables with stack info ------------------       g <- {-# SCC "setInfoTableStackMap" #-}-            return $ map (setInfoTableStackMap dflags stackmaps) g-       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g--       ----------- Control-flow optimisations ------------------------------       g <- {-# SCC "cmmCfgOpts(2)" #-}-            return $ if optLevel dflags >= 1-                     then map (cmmCfgOptsProc splitting_proc_points) g-                     else g-       g <- return (map removeUnreachableBlocksProc g)-            -- See Note [unreachable blocks]-       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g--       return (cafEnv, g)--  where dflags = hsc_dflags hsc_env-        platform = targetPlatform dflags-        dump = dumpGraph dflags--        dumps flag name-           = mapM_ (dumpWith dflags flag name FormatCMM . ppr)--        condPass flag pass g dumpflag dumpname =-            if gopt flag dflags-               then do-                    g <- return $ pass g-                    dump dumpflag dumpname g-                    return g-               else return g--        -- we don't need to split proc points for the NCG, unless-        -- tablesNextToCode is off.  The latter is because we have no-        -- label to put on info tables for basic blocks that are not-        -- the entry point.-        splitting_proc_points = hscTarget dflags /= HscAsm-                             || not (tablesNextToCode dflags)-                             || -- Note [inconsistent-pic-reg]-                                usingInconsistentPicReg-        usingInconsistentPicReg-           = case (platformArch platform, platformOS platform, positionIndependent dflags)-             of   (ArchX86, OSDarwin, pic) -> pic-                  _                        -> False---- Note [Sinking after stack layout]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ In the past we considered running sinking pass also before stack--- layout, but after making some measurements we realized that:------   a) running sinking only before stack layout produces slower---      code than running sinking only before stack layout------   b) running sinking both before and after stack layout produces---      code that has the same performance as when running sinking---      only after stack layout.------ In other words sinking before stack layout doesn't buy as anything.------ An interesting question is "why is it better to run sinking after--- stack layout"? It seems that the major reason are stores and loads--- generated by stack layout. Consider this code before stack layout:------  c1E:---      _c1C::P64 = R3;---      _c1B::P64 = R2;---      _c1A::P64 = R1;---      I64[(young<c1D> + 8)] = c1D;---      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;---  c1D:---      R3 = _c1C::P64;---      R2 = _c1B::P64;---      R1 = _c1A::P64;---      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;------ Stack layout pass will save all local variables live across a call--- (_c1C, _c1B and _c1A in this example) on the stack just before--- making a call and reload them from the stack after returning from a--- call:------  c1E:---      _c1C::P64 = R3;---      _c1B::P64 = R2;---      _c1A::P64 = R1;---      I64[Sp - 32] = c1D;---      P64[Sp - 24] = _c1A::P64;---      P64[Sp - 16] = _c1B::P64;---      P64[Sp - 8] = _c1C::P64;---      Sp = Sp - 32;---      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;---  c1D:---      _c1A::P64 = P64[Sp + 8];---      _c1B::P64 = P64[Sp + 16];---      _c1C::P64 = P64[Sp + 24];---      R3 = _c1C::P64;---      R2 = _c1B::P64;---      R1 = _c1A::P64;---      Sp = Sp + 32;---      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;------ If we don't run sinking pass after stack layout we are basically--- left with such code. However, running sinking on this code can lead--- to significant improvements:------  c1E:---      I64[Sp - 32] = c1D;---      P64[Sp - 24] = R1;---      P64[Sp - 16] = R2;---      P64[Sp - 8] = R3;---      Sp = Sp - 32;---      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;---  c1D:---      R3 = P64[Sp + 24];---      R2 = P64[Sp + 16];---      R1 = P64[Sp + 8];---      Sp = Sp + 32;---      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;------ Now we only have 9 assignments instead of 15.------ There is one case when running sinking before stack layout could--- be beneficial. Consider this:------   L1:---      x = y---      call f() returns L2---   L2: ...x...y...------ Since both x and y are live across a call to f, they will be stored--- on the stack during stack layout and restored after the call:------   L1:---      x = y---      P64[Sp - 24] = L2---      P64[Sp - 16] = x---      P64[Sp - 8]  = y---      Sp = Sp - 24---      call f() returns L2---   L2:---      y = P64[Sp + 16]---      x = P64[Sp + 8]---      Sp = Sp + 24---      ...x...y...------ However, if we run sinking before stack layout we would propagate x--- to its usage place (both x and y must be local register for this to--- be possible - global registers cannot be floated past a call):------   L1:---      x = y---      call f() returns L2---   L2: ...y...y...------ Thus making x dead at the call to f(). If we ran stack layout now--- we would generate less stores and loads:------   L1:---      x = y---      P64[Sp - 16] = L2---      P64[Sp - 8]  = y---      Sp = Sp - 16---      call f() returns L2---   L2:---      y = P64[Sp + 8]---      Sp = Sp + 16---      ...y...y...------ But since we don't see any benefits from running sinking befroe stack--- layout, this situation probably doesn't arise too often in practice.-----{- Note [inconsistent-pic-reg]--On x86/Darwin, PIC is implemented by inserting a sequence like--    call 1f- 1: popl %reg--at the proc entry point, and then referring to labels as offsets from-%reg.  If we don't split proc points, then we could have many entry-points in a proc that would need this sequence, and each entry point-would then get a different value for %reg.  If there are any join-points, then at the join point we don't have a consistent value for-%reg, so we don't know how to refer to labels.--Hence, on x86/Darwin, we have to split proc points, and then each proc-point will get its own PIC initialisation sequence.--This isn't an issue on x86/ELF, where the sequence is--    call 1f- 1: popl %reg-    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg--so %reg always has a consistent value: the address of-_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.---}--{- Note [unreachable blocks]--The control-flow optimiser sometimes leaves unreachable blocks behind-containing junk code.  These aren't necessarily a problem, but-removing them is good because it might save time in the native code-generator later.---}--runUniqSM :: UniqSM a -> IO a-runUniqSM m = do-  us <- mkSplitUniqSupply 'u'-  return (initUs_ us m)---dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()-dumpGraph dflags flag name g = do-  when (gopt Opt_DoCmmLinting dflags) $ do_lint g-  dumpWith dflags flag name FormatCMM (ppr g)- where-  do_lint g = case cmmLintGraph dflags g of-                 Just err -> do { fatalErrorMsg dflags err-                                ; ghcExit dflags 1-                                }-                 Nothing  -> return ()--dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpWith dflags flag txt fmt sdoc = do-  dumpIfSet_dyn dflags flag txt fmt sdoc-  when (not (dopt flag dflags)) $-    -- If `-ddump-cmm-verbose -ddump-to-file` is specified,-    -- dump each Cmm pipeline stage output to a separate file.  #16930-    when (dopt Opt_D_dump_cmm_verbose dflags)-      $ dumpAction dflags (mkDumpStyle dflags alwaysQualify)-                   (dumpOptionsFromFlag flag) txt fmt sdoc-  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
− compiler/cmm/CmmProcPoint.hs 
@@ -1,496 +0,0 @@-{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}--module CmmProcPoint-    ( ProcPointSet, Status(..)-    , callProcPoints, minimalProcPointSet-    , splitAtProcPoints, procPointAnalysis-    , attachContInfoTables-    )-where--import GhcPrelude hiding (last, unzip, succ, zip)--import DynFlags-import BlockId-import CLabel-import Cmm-import PprCmm () -- For Outputable instances-import CmmUtils-import CmmInfo-import CmmLive-import CmmSwitch-import Data.List (sortBy)-import Maybes-import Control.Monad-import Outputable-import GHC.Platform-import UniqSupply-import Hoopl.Block-import Hoopl.Collections-import Hoopl.Dataflow-import Hoopl.Graph-import Hoopl.Label---- Compute a minimal set of proc points for a control-flow graph.---- Determine a protocol for each proc point (which live variables will--- be passed as arguments and which will be on the stack).--{--A proc point is a basic block that, after CPS transformation, will-start a new function.  The entry block of the original function is a-proc point, as is the continuation of each function call.-A third kind of proc point arises if we want to avoid copying code.-Suppose we have code like the following:--  f() {-    if (...) { ..1..; call foo(); ..2..}-    else     { ..3..; call bar(); ..4..}-    x = y + z;-    return x;-  }--The statement 'x = y + z' can be reached from two different proc-points: the continuations of foo() and bar().  We would prefer not to-put a copy in each continuation; instead we would like 'x = y + z' to-be the start of a new procedure to which the continuations can jump:--  f_cps () {-    if (...) { ..1..; push k_foo; jump foo_cps(); }-    else     { ..3..; push k_bar; jump bar_cps(); }-  }-  k_foo() { ..2..; jump k_join(y, z); }-  k_bar() { ..4..; jump k_join(y, z); }-  k_join(y, z) { x = y + z; return x; }--You might think then that a criterion to make a node a proc point is-that it is directly reached by two distinct proc points.  (Note-[Direct reachability].)  But this criterion is a bit too simple; for-example, 'return x' is also reached by two proc points, yet there is-no point in pulling it out of k_join.  A good criterion would be to-say that a node should be made a proc point if it is reached by a set-of proc points that is different than its immediate dominator.  NR-believes this criterion can be shown to produce a minimum set of proc-points, and given a dominator tree, the proc points can be chosen in-time linear in the number of blocks.  Lacking a dominator analysis,-however, we turn instead to an iterative solution, starting with no-proc points and adding them according to these rules:--  1. The entry block is a proc point.-  2. The continuation of a call is a proc point.-  3. A node is a proc point if it is directly reached by more proc-     points than one of its predecessors.--Because we don't understand the problem very well, we apply rule 3 at-most once per iteration, then recompute the reachability information.-(See Note [No simple dataflow].)  The choice of the new proc point is-arbitrary, and I don't know if the choice affects the final solution,-so I don't know if the number of proc points chosen is the-minimum---but the set will be minimal.----Note [Proc-point analysis]-~~~~~~~~~~~~~~~~~~~~~~~~~~--Given a specified set of proc-points (a set of block-ids), "proc-point-analysis" figures out, for every block, which proc-point it belongs to.-All the blocks belonging to proc-point P will constitute a single-top-level C procedure.--A non-proc-point block B "belongs to" a proc-point P iff B is-reachable from P without going through another proc-point.--Invariant: a block B should belong to at most one proc-point; if it-belongs to two, that's a bug.--Note [Non-existing proc-points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--On some architectures it might happen that the list of proc-points-computed before stack layout pass will be invalidated by the stack-layout. This will happen if stack layout removes from the graph-blocks that were determined to be proc-points. Later on in the pipeline-we use list of proc-points to perform [Proc-point analysis], but-if a proc-point does not exist anymore then we will get compiler panic.-See #8205.--}--type ProcPointSet = LabelSet--data Status-  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block-  | ProcPoint               -- this block is itself a proc point--instance Outputable Status where-  ppr (ReachedBy ps)-      | setNull ps = text "<not-reached>"-      | otherwise = text "reached by" <+>-                    (hsep $ punctuate comma $ map ppr $ setElems ps)-  ppr ProcPoint = text "<procpt>"------------------------------------------------------- Proc point analysis---- Once you know what the proc-points are, figure out--- what proc-points each block is reachable from--- See Note [Proc-point analysis]-procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status-procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =-    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints-  where-    initProcPoints =-        mkFactBase-            procPointLattice-            [ (id, ProcPoint)-            | id <- setElems procPoints-            -- See Note [Non-existing proc-points]-            , id `setMember` labelsInGraph-            ]-    labelsInGraph = labelsDefined graph--procPointTransfer :: TransferFun Status-procPointTransfer block facts =-    let label = entryLabel block-        !fact = case getFact procPointLattice label facts of-            ProcPoint -> ReachedBy $! setSingleton label-            f -> f-        result = map (\id -> (id, fact)) (successors block)-    in mkFactBase procPointLattice result--procPointLattice :: DataflowLattice Status-procPointLattice = DataflowLattice unreached add_to-  where-    unreached = ReachedBy setEmpty-    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint-    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case-    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))-        | setSize union > setSize p = Changed (ReachedBy union)-        | otherwise = NotChanged (ReachedBy p)-      where-        union = setUnion p' p---------------------------------------------------------------------------- It is worth distinguishing two sets of proc points: those that are--- induced by calls in the original graph and those that are--- introduced because they're reachable from multiple proc points.------ Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].-callProcPoints      :: CmmGraph -> ProcPointSet-callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g-  where add :: LabelSet -> CmmBlock -> LabelSet-        add set b = case lastNode b of-                      CmmCall {cml_cont = Just k} -> setInsert k set-                      CmmForeignCall {succ=k}     -> setInsert k set-                      _ -> set--minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph-                    -> UniqSM ProcPointSet--- Given the set of successors of calls (which must be proc-points)--- figure out the minimal set of necessary proc-points-minimalProcPointSet platform callProcPoints g-  = extendPPSet platform g (revPostorder g) callProcPoints--extendPPSet-    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet-extendPPSet platform g blocks procPoints =-    let env = procPointAnalysis procPoints g-        add pps block = let id = entryLabel block-                        in  case mapLookup id env of-                              Just ProcPoint -> setInsert id pps-                              _ -> pps-        procPoints' = foldlGraphBlocks add setEmpty g-        newPoints = mapMaybe ppSuccessor blocks-        newPoint  = listToMaybe newPoints-        ppSuccessor b =-            let nreached id = case mapLookup id env `orElse`-                                    pprPanic "no ppt" (ppr id <+> ppr b) of-                                ProcPoint -> 1-                                ReachedBy ps -> setSize ps-                block_procpoints = nreached (entryLabel b)-                -- | Looking for a successor of b that is reached by-                -- more proc points than b and is not already a proc-                -- point.  If found, it can become a proc point.-                newId succ_id = not (setMember succ_id procPoints') &&-                                nreached succ_id > block_procpoints-            in  listToMaybe $ filter newId $ successors b--    in case newPoint of-         Just id ->-             if setMember id procPoints'-                then panic "added old proc pt"-                else extendPPSet platform g blocks (setInsert id procPoints')-         Nothing -> return procPoints'----- At this point, we have found a set of procpoints, each of which should be--- the entry point of a procedure.--- Now, we create the procedure for each proc point,--- which requires that we:--- 1. build a map from proc points to the blocks reachable from the proc point--- 2. turn each branch to a proc point into a jump--- 3. turn calls and returns into jumps--- 4. build info tables for the procedures -- and update the info table for---    the SRTs in the entry procedure as well.--- Input invariant: A block should only be reachable from a single ProcPoint.--- ToDo: use the _ret naming convention that the old code generator--- used. -- EZY-splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->-                     CmmDecl -> UniqSM [CmmDecl]-splitAtProcPoints dflags entry_label callPPs procPoints procMap-                  (CmmProc (TopInfo {info_tbls = info_tbls})-                           top_l _ g@(CmmGraph {g_entry=entry})) =-  do -- Build a map from procpoints to the blocks they reach-     let add_block-             :: LabelMap (LabelMap CmmBlock)-             -> CmmBlock-             -> LabelMap (LabelMap CmmBlock)-         add_block graphEnv b =-           case mapLookup bid procMap of-             Just ProcPoint -> add graphEnv bid bid b-             Just (ReachedBy set) ->-               case setElems set of-                 []   -> graphEnv-                 [id] -> add graphEnv id bid b-                 _    -> panic "Each block should be reachable from only one ProcPoint"-             Nothing -> graphEnv-           where bid = entryLabel b-         add graphEnv procId bid b = mapInsert procId graph' graphEnv-               where graph  = mapLookup procId graphEnv `orElse` mapEmpty-                     graph' = mapInsert bid b graph--     let liveness = cmmGlobalLiveness dflags g-     let ppLiveness pp = filter isArgReg $-                         regSetToList $-                         expectJust "ppLiveness" $ mapLookup pp liveness--     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g--     -- Build a map from proc point BlockId to pairs of:-     --  * Labels for their new procedures-     --  * Labels for the info tables of their new procedures (only if-     --    the proc point is a callPP)-     -- Due to common blockification, we may overestimate the set of procpoints.-     let add_label map pp = mapInsert pp lbls map-           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))-                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>-                                                    Just info_table_lbl)-                      where block_lbl      = blockLbl pp-                            info_table_lbl = infoTblLbl pp--         procLabels :: LabelMap (CLabel, Maybe CLabel)-         procLabels = foldl' add_label mapEmpty-                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))--     -- In each new graph, add blocks jumping off to the new procedures,-     -- and replace branches to procpoints with branches to the jump-off blocks-     let add_jump_block-             :: (LabelMap Label, [CmmBlock])-             -> (Label, CLabel)-             -> UniqSM (LabelMap Label, [CmmBlock])-         add_jump_block (env, bs) (pp, l) =-           do bid <- liftM mkBlockId getUniqueM-              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump-                  live = ppLiveness pp-                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0-              return (mapInsert pp bid env, b : bs)--         add_jumps-             :: LabelMap CmmGraph-             -> (Label, LabelMap CmmBlock)-             -> UniqSM (LabelMap CmmGraph)-         add_jumps newGraphEnv (ppId, blockEnv) =-           do let needed_jumps = -- find which procpoints we currently branch to-                    mapFoldr add_if_branch_to_pp [] blockEnv-                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]-                  add_if_branch_to_pp block rst =-                    case lastNode block of-                      CmmBranch id          -> add_if_pp id rst-                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)-                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids-                      _                     -> rst--                  -- when jumping to a PP that has an info table, if-                  -- tablesNextToCode is off we must jump to the entry-                  -- label instead.-                  jump_label (Just info_lbl) _-                             | tablesNextToCode dflags = info_lbl-                             | otherwise               = toEntryLbl info_lbl-                  jump_label Nothing         block_lbl = block_lbl--                  add_if_pp id rst = case mapLookup id procLabels of-                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst-                                       Nothing                 -> rst-              (jumpEnv, jumpBlocks) <--                 foldM add_jump_block (mapEmpty, []) needed_jumps-                  -- update the entry block-              let b = expectJust "block in env" $ mapLookup ppId blockEnv-                  blockEnv' = mapInsert ppId b blockEnv-                  -- replace branches to procpoints with branches to jumps-                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'-                  -- add the jump blocks to the graph-                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks-              let g' = ofBlockMap ppId blockEnv'''-              -- pprTrace "g' pre jumps" (ppr g') $ do-              return (mapInsert ppId g' newGraphEnv)--     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv--     let to_proc (bid, g)-             | bid == entry-             =  CmmProc (TopInfo {info_tbls  = info_tbls,-                                  stack_info = stack_info})-                        top_l live g'-             | otherwise-             = case expectJust "pp label" $ mapLookup bid procLabels of-                 (lbl, Just info_lbl)-                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)-                                        , stack_info=stack_info})-                               lbl live g'-                 (lbl, Nothing)-                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})-                               lbl live g'-                where-                 g' = replacePPIds g-                 live = ppLiveness (g_entry g')-                 stack_info = StackInfo { arg_space = 0-                                        , updfr_space =  Nothing-                                        , do_layout = True }-                               -- cannot use panic, this is printed by -ddump-cmm--         -- References to procpoint IDs can now be replaced with the-         -- infotable's label-         replacePPIds g = {-# SCC "replacePPIds" #-}-                          mapGraphNodes (id, mapExp repl, mapExp repl) g-           where repl e@(CmmLit (CmmBlock bid)) =-                   case mapLookup bid procLabels of-                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)-                     _ -> e-                 repl e = e--     -- The C back end expects to see return continuations before the-     -- call sites.  Here, we sort them in reverse order -- it gets-     -- reversed later.-     let (_, block_order) =-             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)-                   (revPostorder g)-         add_block_num (i, map) block =-           (i + 1, mapInsert (entryLabel block) i map)-         sort_fn (bid, _) (bid', _) =-           compare (expectJust "block_order" $ mapLookup bid  block_order)-                   (expectJust "block_order" $ mapLookup bid' block_order)-     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv-     return -- pprTrace "procLabels" (ppr procLabels)-            -- pprTrace "splitting graphs" (ppr procs)-            procs-splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]---- Only called from CmmProcPoint.splitAtProcPoints. NB. does a--- recursive lookup, see comment below.-replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph-replaceBranches env cmmg-  = {-# SCC "replaceBranches" #-}-    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg-  where-    f block = replaceLastNode block $ last (lastNode block)--    last :: CmmNode O C -> CmmNode O C-    last (CmmBranch id)          = CmmBranch (lookup id)-    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l-    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)-    last l@(CmmCall {})          = l { cml_cont = Nothing }-            -- NB. remove the continuation of a CmmCall, since this-            -- label will now be in a different CmmProc.  Not only-            -- is this tidier, it stops CmmLint from complaining.-    last l@(CmmForeignCall {})   = l-    lookup id = fmap lookup (mapLookup id env) `orElse` id-            -- XXX: this is a recursive lookup, it follows chains-            -- until the lookup returns Nothing, at which point we-            -- return the last BlockId---- ----------------------------------------------------------------- Not splitting proc points: add info tables for continuations--attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl-attachContInfoTables call_proc_points (CmmProc top_info top_l live g)- = CmmProc top_info{info_tbls = info_tbls'} top_l live g- where-   info_tbls' = mapUnion (info_tbls top_info) $-                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))-                            | l <- setElems call_proc_points-                            , l /= g_entry g ]-attachContInfoTables _ other_decl- = other_decl--------------------------------------------------------------------{--Note [Direct reachability]--Block B is directly reachable from proc point P iff control can flow-from P to B without passing through an intervening proc point.--}--------------------------------------------------------------------{--Note [No simple dataflow]--Sadly, it seems impossible to compute the proc points using a single-dataflow pass.  One might attempt to use this simple lattice:--  data Location = Unknown-                | InProc BlockId -- node is in procedure headed by the named proc point-                | ProcPoint      -- node is itself a proc point--At a join, a node in two different blocks becomes a proc point.-The difficulty is that the change of information during iterative-computation may promote a node prematurely.  Here's a program that-illustrates the difficulty:--  f () {-  entry:-    ....-  L1:-    if (...) { ... }-    else { ... }--  L2: if (...) { g(); goto L1; }-      return x + y;-  }--The only proc-point needed (besides the entry) is L1.  But in an-iterative analysis, consider what happens to L2.  On the first pass-through, it rises from Unknown to 'InProc entry', but when L1 is-promoted to a proc point (because it's the successor of g()), L1's-successors will be promoted to 'InProc L1'.  The problem hits when the-new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.-The join operation makes it a proc point when in fact it needn't be,-because its immediate dominator L1 is already a proc point and there-are no other proc points that directly reach L2.--}----{- Note [Separate Adams optimization]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It may be worthwhile to attempt the Adams optimization by rewriting-the graph before the assignment of proc-point protocols.  Here are a-couple of rules:--  g() returns to k;                    g() returns to L;-  k: CopyIn c ress; goto L:-   ...                        ==>        ...-  L: // no CopyIn node here            L: CopyIn c ress;---And when c == c' and ress == ress', this also:--  g() returns to k;                    g() returns to L;-  k: CopyIn c ress; goto L:-   ...                        ==>        ...-  L: CopyIn c' ress'                   L: CopyIn c' ress' ;--In both cases the goal is to eliminate k.--}
− compiler/cmm/CmmSink.hs 
@@ -1,854 +0,0 @@-{-# LANGUAGE GADTs #-}-module CmmSink (-     cmmSink-  ) where--import GhcPrelude--import Cmm-import CmmOpt-import CmmLive-import CmmUtils-import Hoopl.Block-import Hoopl.Label-import Hoopl.Collections-import Hoopl.Graph-import GHC.Platform.Regs-import GHC.Platform (isARM, platformArch)--import DynFlags-import Unique-import UniqFM--import qualified Data.IntSet as IntSet-import Data.List (partition)-import qualified Data.Set as Set-import Data.Maybe---- Compact sets for membership tests of local variables.--type LRegSet = IntSet.IntSet--emptyLRegSet :: LRegSet-emptyLRegSet = IntSet.empty--nullLRegSet :: LRegSet -> Bool-nullLRegSet = IntSet.null--insertLRegSet :: LocalReg -> LRegSet -> LRegSet-insertLRegSet l = IntSet.insert (getKey (getUnique l))--elemLRegSet :: LocalReg -> LRegSet -> Bool-elemLRegSet l = IntSet.member (getKey (getUnique l))---- -------------------------------------------------------------------------------- Sinking and inlining---- This is an optimisation pass that---  (a) moves assignments closer to their uses, to reduce register pressure---  (b) pushes assignments into a single branch of a conditional if possible---  (c) inlines assignments to registers that are mentioned only once---  (d) discards dead assignments------ This tightens up lots of register-heavy code.  It is particularly--- helpful in the Cmm generated by the Stg->Cmm code generator, in--- which every function starts with a copyIn sequence like:------    x1 = R1---    x2 = Sp[8]---    x3 = Sp[16]---    if (Sp - 32 < SpLim) then L1 else L2------ we really want to push the x1..x3 assignments into the L2 branch.------ Algorithm:------  * Start by doing liveness analysis.------  * Keep a list of assignments A; earlier ones may refer to later ones.---    Currently we only sink assignments to local registers, because we don't---    have liveness information about global registers.------  * Walk forwards through the graph, look at each node N:------    * If it is a dead assignment, i.e. assignment to a register that is---      not used after N, discard it.------    * Try to inline based on current list of assignments---      * If any assignments in A (1) occur only once in N, and (2) are---        not live after N, inline the assignment and remove it---        from A.------      * If an assignment in A is cheap (RHS is local register), then---        inline the assignment and keep it in A in case it is used afterwards.------      * Otherwise don't inline.------    * If N is assignment to a local register pick up the assignment---      and add it to A.------    * If N is not an assignment to a local register:---      * remove any assignments from A that conflict with N, and---        place them before N in the current block.  We call this---        "dropping" the assignments.------      * An assignment conflicts with N if it:---        - assigns to a register mentioned in N---        - mentions a register assigned by N---        - reads from memory written by N---      * do this recursively, dropping dependent assignments------    * At an exit node:---      * drop any assignments that are live on more than one successor---        and are not trivial---      * if any successor has more than one predecessor (a join-point),---        drop everything live in that successor. Since we only propagate---        assignments that are not dead at the successor, we will therefore---        eliminate all assignments dead at this point. Thus analysis of a---        join-point will always begin with an empty list of assignments.--------- As a result of above algorithm, sinking deletes some dead assignments--- (transitively, even).  This isn't as good as removeDeadAssignments,--- but it's much cheaper.---- -------------------------------------------------------------------------------- things that we aren't optimising very well yet.------ -------------- (1) From GHC's FastString.hashStr:------  s2ay:---      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;---  c2gn:---      R1 = _s2au::I64;---      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;---  c2gp:---      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,---                                 4091);---      _s2an::I64 = _s2an::I64 + 1;---      _s2au::I64 = _s2cO::I64;---      goto s2ay;------ a nice loop, but we didn't eliminate the silly assignment at the end.--- See Note [dependent assignments], which would probably fix this.--- This is #8336.------ -------------- (2) From stg_atomically_frame in PrimOps.cmm------ We have a diamond control flow:------     x = ...---       |---      / \---     A   B---      \ /---       |---    use of x------ Now x won't be sunk down to its use, because we won't push it into--- both branches of the conditional.  We certainly do have to check--- that we can sink it past all the code in both A and B, but having--- discovered that, we could sink it to its use.------- -------------------------------------------------------------------------------type Assignment = (LocalReg, CmmExpr, AbsMem)-  -- Assignment caches AbsMem, an abstraction of the memory read by-  -- the RHS of the assignment.--type Assignments = [Assignment]-  -- A sequence of assignments; kept in *reverse* order-  -- So the list [ x=e1, y=e2 ] means the sequence of assignments-  --     y = e2-  --     x = e1--cmmSink :: DynFlags -> CmmGraph -> CmmGraph-cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks-  where-  liveness = cmmLocalLiveness dflags graph-  getLive l = mapFindWithDefault Set.empty l liveness--  blocks = revPostorder graph--  join_pts = findJoinPoints blocks--  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]-  sink _ [] = []-  sink sunk (b:bs) =-    -- pprTrace "sink" (ppr lbl) $-    blockJoin first final_middle final_last : sink sunk' bs-    where-      lbl = entryLabel b-      (first, middle, last) = blockSplit b--      succs = successors last--      -- Annotate the middle nodes with the registers live *after*-      -- the node.  This will help us decide whether we can inline-      -- an assignment in the current node or not.-      live = Set.unions (map getLive succs)-      live_middle = gen_kill dflags last live-      ann_middles = annotate dflags live_middle (blockToList middle)--      -- Now sink and inline in this block-      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)-      fold_last = constantFoldNode dflags last-      (final_last, assigs') = tryToInline dflags live fold_last assigs--      -- We cannot sink into join points (successors with more than-      -- one predecessor), so identify the join points and the set-      -- of registers live in them.-      (joins, nonjoins) = partition (`mapMember` join_pts) succs-      live_in_joins = Set.unions (map getLive joins)--      -- We do not want to sink an assignment into multiple branches,-      -- so identify the set of registers live in multiple successors.-      -- This is made more complicated because when we sink an assignment-      -- into one branch, this might change the set of registers that are-      -- now live in multiple branches.-      init_live_sets = map getLive nonjoins-      live_in_multi live_sets r =-         case filter (Set.member r) live_sets of-           (_one:_two:_) -> True-           _ -> False--      -- Now, drop any assignments that we will not sink any further.-      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'--      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')-          where-            should_drop =  conflicts dflags a final_last-                        || not (isTrivial dflags rhs) && live_in_multi live_sets r-                        || r `Set.member` live_in_joins--            live_sets' | should_drop = live_sets-                       | otherwise   = map upd live_sets--            upd set | r `Set.member` set = set `Set.union` live_rhs-                    | otherwise          = set--            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs--      final_middle = foldl' blockSnoc middle' dropped_last--      sunk' = mapUnion sunk $-                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')-                             | l <- succs ]--{- TODO: enable this later, when we have some good tests in place to-   measure the effect and tune it.---- small: an expression we don't mind duplicating-isSmall :: CmmExpr -> Bool-isSmall (CmmReg (CmmLocal _)) = True  ---isSmall (CmmLit _) = True-isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y-isSmall (CmmRegOff (CmmLocal _) _) = True-isSmall _ = False--}------- We allow duplication of trivial expressions: registers (both local and--- global) and literals.----isTrivial :: DynFlags -> CmmExpr -> Bool-isTrivial _ (CmmReg (CmmLocal _)) = True-isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]-  if isARM (platformArch (targetPlatform dflags))-  then True -- CodeGen.Platform.ARM does not have globalRegMaybe-  else isJust (globalRegMaybe (targetPlatform dflags) r)-  -- GlobalRegs that are loads from BaseReg are not trivial-isTrivial _ (CmmLit _) = True-isTrivial _ _          = False------- annotate each node with the set of registers live *after* the node----annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]-annotate dflags live nodes = snd $ foldr ann (live,[]) nodes-  where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)------- Find the blocks that have multiple successors (join points)----findJoinPoints :: [CmmBlock] -> LabelMap Int-findJoinPoints blocks = mapFilter (>1) succ_counts- where-  all_succs = concatMap successors blocks--  succ_counts :: LabelMap Int-  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs------- filter the list of assignments to remove any assignments that--- are not live in a continuation.----filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments-filterAssignments dflags live assigs = reverse (go assigs [])-  where go []             kept = kept-        go (a@(r,_,_):as) kept | needed    = go as (a:kept)-                               | otherwise = go as kept-           where-              needed = r `Set.member` live-                       || any (conflicts dflags a) (map toNode kept)-                       --  Note that we must keep assignments that are-                       -- referred to by other assignments we have-                       -- already kept.---- -------------------------------------------------------------------------------- Walk through the nodes of a block, sinking and inlining assignments--- as we go.------ On input we pass in a:---    * list of nodes in the block---    * a list of assignments that appeared *before* this block and---      that are being sunk.------ On output we get:---    * a new block---    * a list of assignments that will be placed *after* that block.-----walk :: DynFlags-     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with-                                        -- the set of registers live *after*-                                        -- this node.--     -> Assignments                     -- The current list of-                                        -- assignments we are sinking.-                                        -- Earlier assignments may refer-                                        -- to later ones.--     -> ( Block CmmNode O O             -- The new block-        , Assignments                   -- Assignments to sink further-        )--walk dflags nodes assigs = go nodes emptyBlock assigs- where-   go []               block as = (block, as)-   go ((live,node):ns) block as-    | shouldDiscard node live           = go ns block as-       -- discard dead assignment-    | Just a <- shouldSink dflags node2 = go ns block (a : as1)-    | otherwise                         = go ns block' as'-    where-      node1 = constantFoldNode dflags node--      (node2, as1) = tryToInline dflags live node1 as--      (dropped, as') = dropAssignmentsSimple dflags-                          (\a -> conflicts dflags a node2) as1--      block' = foldl' blockSnoc block dropped `blockSnoc` node2-------- Heuristic to decide whether to pick up and sink an assignment--- Currently we pick up all assignments to local registers.  It might--- be profitable to sink assignments to global regs too, but the--- liveness analysis doesn't track those (yet) so we can't.----shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment-shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)-  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e-shouldSink _ _other = Nothing------- discard dead assignments.  This doesn't do as good a job as--- removeDeadAssignments, because it would need multiple passes--- to get all the dead code, but it catches the common case of--- superfluous reloads from the stack that the stack allocator--- leaves behind.------ Also we catch "r = r" here.  You might think it would fall--- out of inlining, but the inliner will see that r is live--- after the instruction and choose not to inline r in the rhs.----shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool-shouldDiscard node live-   = case node of-       CmmAssign r (CmmReg r') | r == r' -> True-       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)-       _otherwise -> False---toNode :: Assignment -> CmmNode O O-toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs--dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments-                      -> ([CmmNode O O], Assignments)-dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()--dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments-                -> ([CmmNode O O], Assignments)-dropAssignments dflags should_drop state assigs- = (dropped, reverse kept)- where-   (dropped,kept) = go state assigs [] []--   go _ []             dropped kept = (dropped, kept)-   go state (assig : rest) dropped kept-      | conflict  = go state' rest (toNode assig : dropped) kept-      | otherwise = go state' rest dropped (assig:kept)-      where-        (dropit, state') = should_drop assig state-        conflict = dropit || any (conflicts dflags assig) dropped----- -------------------------------------------------------------------------------- Try to inline assignments into a node.--- This also does constant folding for primpops, since--- inlining opens up opportunities for doing so.--tryToInline-   :: DynFlags-   -> LocalRegSet               -- set of registers live after this-                                -- node.  We cannot inline anything-                                -- that is live after the node, unless-                                -- it is small enough to duplicate.-   -> CmmNode O x               -- The node to inline into-   -> Assignments               -- Assignments to inline-   -> (-        CmmNode O x             -- New node-      , Assignments             -- Remaining assignments-      )--tryToInline dflags live node assigs = go usages node emptyLRegSet assigs- where-  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used-  usages = foldLocalRegsUsed dflags addUsage emptyUFM node--  go _usages node _skipped [] = (node, [])--  go usages node skipped (a@(l,rhs,_) : rest)-   | cannot_inline           = dont_inline-   | occurs_none             = discard  -- Note [discard during inlining]-   | occurs_once             = inline_and_discard-   | isTrivial dflags rhs    = inline_and_keep-   | otherwise               = dont_inline-   where-        inline_and_discard = go usages' inl_node skipped rest-          where usages' = foldLocalRegsUsed dflags addUsage usages rhs--        discard = go usages node skipped rest--        dont_inline        = keep node  -- don't inline the assignment, keep it-        inline_and_keep    = keep inl_node -- inline the assignment, keep it--        keep node' = (final_node, a : rest')-          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest-                usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)-                                            usages rhs-                -- we must not inline anything that is mentioned in the RHS-                -- of a binding that we have already skipped, so we set the-                -- usages of the regs on the RHS to 2.--        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]-                        || l `elemLRegSet` skipped-                        || not (okToInline dflags rhs node)--        l_usages = lookupUFM usages l-        l_live   = l `elemRegSet` live--        occurs_once = not l_live && l_usages == Just 1-        occurs_none = not l_live && l_usages == Nothing--        inl_node = improveConditional (mapExpDeep inl_exp node)--        inl_exp :: CmmExpr -> CmmExpr-        -- inl_exp is where the inlining actually takes place!-        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs-        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'-                    = cmmOffset dflags rhs off-                    -- re-constant fold after inlining-        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args-        inl_exp other = other---{- Note [improveConditional]--cmmMachOpFold tries to simplify conditionals to turn things like-  (a == b) != 1-into-  (a != b)-but there's one case it can't handle: when the comparison is over-floating-point values, we can't invert it, because floating-point-comparisons aren't invertible (because of NaNs).--But we *can* optimise this conditional by swapping the true and false-branches. Given-  CmmCondBranch ((a >## b) != 1) t f-we can turn it into-  CmmCondBranch (a >## b) f t--So here we catch conditionals that weren't optimised by cmmMachOpFold,-and apply above transformation to eliminate the comparison against 1.--It's tempting to just turn every != into == and then let cmmMachOpFold-do its thing, but that risks changing a nice fall-through conditional-into one that requires two jumps. (see swapcond_last in-CmmContFlowOpt), so instead we carefully look for just the cases where-we can eliminate a comparison.--}-improveConditional :: CmmNode O x -> CmmNode O x-improveConditional-  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)-  | neLike mop, isComparisonExpr x-  = CmmCondBranch x f t (fmap not l)-  where-    neLike (MO_Ne _) = True-    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1-    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1-    neLike _ = False-improveConditional other = other---- Note [dependent assignments]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If our assignment list looks like------    [ y = e,  x = ... y ... ]------ We cannot inline x.  Remember this list is really in reverse order,--- so it means  x = ... y ...; y = e------ Hence if we inline x, the outer assignment to y will capture the--- reference in x's right hand side.------ In this case we should rename the y in x's right-hand side,--- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]--- Now we can go ahead and inline x.------ For now we do nothing, because this would require putting--- everything inside UniqSM.------ One more variant of this (#7366):------   [ y = e, y = z ]------ If we don't want to inline y = e, because y is used many times, we--- might still be tempted to inline y = z (because we always inline--- trivial rhs's).  But of course we can't, because y is equal to e,--- not z.---- Note [discard during inlining]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Opportunities to discard assignments sometimes appear after we've--- done some inlining.  Here's an example:------      x = R1;---      y = P64[x + 7];---      z = P64[x + 15];---      /* z is dead */---      R1 = y & (-8);------ The x assignment is trivial, so we inline it in the RHS of y, and--- keep both x and y.  z gets dropped because it is dead, then we--- inline y, and we have a dead assignment to x.  If we don't notice--- that x is dead in tryToInline, we end up retaining it.--addUsage :: UniqFM Int -> LocalReg -> UniqFM Int-addUsage m r = addToUFM_C (+) m r 1--regsUsedIn :: LRegSet -> CmmExpr -> Bool-regsUsedIn ls _ | nullLRegSet ls = False-regsUsedIn ls e = wrapRecExpf f e False-  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True-        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True-        f _ z = z---- we don't inline into CmmUnsafeForeignCall if the expression refers--- to global registers.  This is a HACK to avoid global registers--- clashing with C argument-passing registers, really the back-end--- ought to be able to handle it properly, but currently neither PprC--- nor the NCG can do it.  See Note [Register parameter passing]--- See also GHC.StgToCmm.Foreign.load_args_into_temps.-okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool-okToInline dflags expr node@(CmmUnsafeForeignCall{}) =-    not (globalRegistersConflict dflags expr node)-okToInline _ _ _ = True---- --------------------------------------------------------------------------------- | @conflicts (r,e) node@ is @False@ if and only if the assignment--- @r = e@ can be safely commuted past statement @node@.-conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool-conflicts dflags (r, rhs, addr) node--  -- (1) node defines registers used by rhs of assignment. This catches-  -- assignments and all three kinds of calls. See Note [Sinking and calls]-  | globalRegistersConflict dflags rhs node                       = True-  | localRegistersConflict  dflags rhs node                       = True--  -- (2) node uses register defined by assignment-  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True--  -- (3) a store to an address conflicts with a read of the same memory-  | CmmStore addr' e <- node-  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True--  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively-  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True-  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True-  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True--  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]-  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True--  -- (6) native calls clobber any memory-  | CmmCall{} <- node, memConflicts addr AnyMem                   = True--  -- (7) otherwise, no conflict-  | otherwise = False---- Returns True if node defines any global registers that are used in the--- Cmm expression-globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool-globalRegistersConflict dflags expr node =-    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)-                 False node---- Returns True if node defines any local registers that are used in the--- Cmm expression-localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool-localRegistersConflict dflags expr node =-    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)-                 False node---- Note [Sinking and calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~------ We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)--- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after--- stack layout (see Note [Sinking after stack layout]) which leads to two--- invariants related to calls:------   a) during stack layout phase all safe foreign calls are turned into---      unsafe foreign calls (see Note [Lower safe foreign calls]). This---      means that we will never encounter CmmForeignCall node when running---      sinking after stack layout------   b) stack layout saves all variables live across a call on the stack---      just before making a call (remember we are not sinking assignments to---      stack):------       L1:---          x = R1---          P64[Sp - 16] = L2---          P64[Sp - 8]  = x---          Sp = Sp - 16---          call f() returns L2---       L2:------      We will attempt to sink { x = R1 } but we will detect conflict with---      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even---      checking whether it conflicts with { call f() }. In this way we will---      never need to check any assignment conflicts with CmmCall. Remember---      that we still need to check for potential memory conflicts.------ So the result is that we only need to worry about CmmUnsafeForeignCall nodes--- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).--- This assumption holds only when we do sinking after stack layout. If we run--- it before stack layout we need to check for possible conflicts with all three--- kinds of calls. Our `conflicts` function does that by using a generic--- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and--- UserOfRegs typeclasses.------- An abstraction of memory read or written.-data AbsMem-  = NoMem            -- no memory accessed-  | AnyMem           -- arbitrary memory-  | HeapMem          -- definitely heap memory-  | StackMem         -- definitely stack memory-  | SpMem            -- <size>[Sp+n]-       {-# UNPACK #-} !Int-       {-# UNPACK #-} !Int---- Having SpMem is important because it lets us float loads from Sp--- past stores to Sp as long as they don't overlap, and this helps to--- unravel some long sequences of---    x1 = [Sp + 8]---    x2 = [Sp + 16]---    ...---    [Sp + 8]  = xi---    [Sp + 16] = xj------ Note that SpMem is invalidated if Sp is changed, but the definition--- of 'conflicts' above handles that.---- ToDo: this won't currently fix the following commonly occurring code:---    x1 = [R1 + 8]---    x2 = [R1 + 16]---    ..---    [Hp - 8] = x1---    [Hp - 16] = x2---    ..---- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that--- assignments to [Hp + n] do not conflict with any other heap memory,--- but this is tricky to nail down.  What if we had------   x = Hp + n---   [x] = ...------  the store to [x] should be "new heap", not "old heap".---  Furthermore, you could imagine that if we started inlining---  functions in Cmm then there might well be reads of heap memory---  that was written in the same basic block.  To take advantage of---  non-aliasing of heap memory we will have to be more clever.---- Note [Foreign calls clobber heap]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ It is tempting to say that foreign calls clobber only--- non-heap/stack memory, but unfortunately we break this invariant in--- the RTS.  For example, in stg_catch_retry_frame we call--- stmCommitNestedTransaction() which modifies the contents of the--- TRec it is passed (this actually caused incorrect code to be--- generated).------ Since the invariant is true for the majority of foreign calls,--- perhaps we ought to have a special annotation for calls that can--- modify heap/stack memory.  For now we just use the conservative--- definition here.------ Some CallishMachOp imply a memory barrier e.g. AtomicRMW and--- therefore we should never float any memory operations across one of--- these calls.---bothMems :: AbsMem -> AbsMem -> AbsMem-bothMems NoMem    x         = x-bothMems x        NoMem     = x-bothMems HeapMem  HeapMem   = HeapMem-bothMems StackMem StackMem     = StackMem-bothMems (SpMem o1 w1) (SpMem o2 w2)-  | o1 == o2  = SpMem o1 (max w1 w2)-  | otherwise = StackMem-bothMems SpMem{}  StackMem  = StackMem-bothMems StackMem SpMem{}   = StackMem-bothMems _         _        = AnyMem--memConflicts :: AbsMem -> AbsMem -> Bool-memConflicts NoMem      _          = False-memConflicts _          NoMem      = False-memConflicts HeapMem    StackMem   = False-memConflicts StackMem   HeapMem    = False-memConflicts SpMem{}    HeapMem    = False-memConflicts HeapMem    SpMem{}    = False-memConflicts (SpMem o1 w1) (SpMem o2 w2)-  | o1 < o2   = o1 + w1 > o2-  | otherwise = o2 + w2 > o1-memConflicts _         _         = True--exprMem :: DynFlags -> CmmExpr -> AbsMem-exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)-exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)-exprMem _      _                 = NoMem--loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem-loadAddr dflags e w =-  case e of-   CmmReg r       -> regAddr dflags r 0 w-   CmmRegOff r i  -> regAddr dflags r i w-   _other | regUsedIn dflags spReg e -> StackMem-          | otherwise -> AnyMem--regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem-regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)-regAddr _      (CmmGlobal Hp) _ _ = HeapMem-regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps-regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself-regAddr _      _ _ _ = AnyMem--{--Note [Inline GlobalRegs?]--Should we freely inline GlobalRegs?--Actually it doesn't make a huge amount of difference either way, so we-*do* currently treat GlobalRegs as "trivial" and inline them-everywhere, but for what it's worth, here is what I discovered when I-(SimonM) looked into this:--Common sense says we should not inline GlobalRegs, because when we-have--  x = R1--the register allocator will coalesce this assignment, generating no-code, and simply record the fact that x is bound to $rbx (or-whatever).  Furthermore, if we were to sink this assignment, then the-range of code over which R1 is live increases, and the range of code-over which x is live decreases.  All things being equal, it is better-for x to be live than R1, because R1 is a fixed register whereas x can-live in any register.  So we should neither sink nor inline 'x = R1'.--However, not inlining GlobalRegs can have surprising-consequences. e.g. (cgrun020)--  c3EN:-      _s3DB::P64 = R1;-      _c3ES::P64 = _s3DB::P64 & 7;-      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;-  c3EU:-      _s3DD::P64 = P64[_s3DB::P64 + 6];-      _s3DE::P64 = P64[_s3DB::P64 + 14];-      I64[Sp - 8] = c3F0;-      R1 = _s3DE::P64;-      P64[Sp] = _s3DD::P64;--inlining the GlobalReg gives:--  c3EN:-      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;-  c3EU:-      I64[Sp - 8] = c3F0;-      _s3DD::P64 = P64[R1 + 6];-      R1 = P64[R1 + 14];-      P64[Sp] = _s3DD::P64;--but if we don't inline the GlobalReg, instead we get:--      _s3DB::P64 = R1;-      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;-  c3EU:-      I64[Sp - 8] = c3F0;-      R1 = P64[_s3DB::P64 + 14];-      P64[Sp] = P64[_s3DB::P64 + 6];--This looks better - we managed to inline _s3DD - but in fact it-generates an extra reg-reg move:--.Lc3EU:-        movq $c3F0_info,-8(%rbp)-        movq %rbx,%rax-        movq 14(%rbx),%rbx-        movq 6(%rax),%rax-        movq %rax,(%rbp)--because _s3DB is now live across the R1 assignment, we lost the-benefit of coalescing.--Who is at fault here?  Perhaps if we knew that _s3DB was an alias for-R1, then we would not sink a reference to _s3DB past the R1-assignment.  Or perhaps we *should* do that - we might gain by sinking-it, despite losing the coalescing opportunity.--Sometimes not inlining global registers wins by virtue of the rule-about not inlining into arguments of a foreign call, e.g. (T7163) this-is what happens when we inlined F1:--      _s3L2::F32 = F1;-      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);-      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);--but if we don't inline F1:--      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,-                                                                                            10.0 :: W32));--}
− compiler/cmm/CmmSwitch.hs 
@@ -1,500 +0,0 @@-{-# LANGUAGE GADTs #-}-module CmmSwitch (-     SwitchTargets,-     mkSwitchTargets,-     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,-     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,-     switchTargetsToList, eqSwitchTargetWith,--     SwitchPlan(..),-     targetSupportsSwitch,-     createSwitchPlan,-  ) where--import GhcPrelude--import Outputable-import DynFlags-import Hoopl.Label (Label)--import Data.Maybe-import Data.List (groupBy)-import Data.Function (on)-import qualified Data.Map as M---- Note [Cmm Switches, the general plan]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ Compiling a high-level switch statement, as it comes out of a STG case--- expression, for example, allows for a surprising amount of design decisions.--- Therefore, we cleanly separated this from the Stg → Cmm transformation, as--- well as from the actual code generation.------ The overall plan is:---  * The Stg → Cmm transformation creates a single `SwitchTargets` in---    emitSwitch and emitCmmLitSwitch in GHC.StgToCmm/Utils.hs.---    At this stage, they are unsuitable for code generation.---  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these---    switch statements with code that is suitable for code generation, i.e.---    a nice balanced tree of decisions with dense jump tables in the leafs.---    The actual planning of this tree is performed in pure code in createSwitchPlan---    in this module. See Note [createSwitchPlan].---  * The actual code generation will not do any further processing and---    implement each CmmSwitch with a jump tables.------ When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch--- statements alone, as we can turn a SwitchTargets value into a nice--- switch-statement in LLVM resp. C, and leave the rest to the compiler.------ See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are--- separated.---------------------------------------------------------------------------------- Note [Magic Constants in CmmSwitch]------ There are a lot of heuristics here that depend on magic values where it is--- hard to determine the "best" value (for whatever that means). These are the--- magic values:---- | Number of consecutive default values allowed in a jump table. If there are--- more of them, the jump tables are split.------ Currently 7, as it costs 7 words of additional code when a jump table is--- split (at least on x64, determined experimentally).-maxJumpTableHole :: Integer-maxJumpTableHole = 7---- | Minimum size of a jump table. If the number is smaller, the switch is--- implemented using conditionals.--- Currently 5, because an if-then-else tree of 4 values is nice and compact.-minJumpTableSize :: Int-minJumpTableSize = 5---- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset].-minJumpTableOffset :: Integer-minJumpTableOffset = 2----------------------------------------------------------------------------------- Switch Targets---- Note [SwitchTargets]:--- ~~~~~~~~~~~~~~~~~~~~~------ The branches of a switch are stored in a SwitchTargets, which consists of an--- (optional) default jump target, and a map from values to jump targets.------ If the default jump target is absent, the behaviour of the switch outside the--- values of the map is undefined.------ We use an Integer for the keys the map so that it can be used in switches on--- unsigned as well as signed integers.------ The map may be empty (we prune out-of-range branches here, so it could be us--- emptying it).------ Before code generation, the table needs to be brought into a form where all--- entries are non-negative, so that it can be compiled into a jump table.--- See switchTargetsToTable.----- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch'--- value, and knows whether the value is signed, the possible range, an--- optional default value and a map from values to jump labels.-data SwitchTargets =-    SwitchTargets-        Bool                       -- Signed values-        (Integer, Integer)         -- Range-        (Maybe Label)              -- Default value-        (M.Map Integer Label)      -- The branches-    deriving (Show, Eq)---- | The smart constructor mkSwitchTargets normalises the map a bit:---  * No entries outside the range---  * No entries equal to the default---  * No default if all elements have explicit values-mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets-mkSwitchTargets signed range@(lo,hi) mbdef ids-    = SwitchTargets signed range mbdef' ids'-  where-    ids' = dropDefault $ restrict ids-    mbdef' | defaultNeeded = mbdef-           | otherwise     = Nothing--    -- Drop entries outside the range, if there is a range-    restrict = restrictMap (lo,hi)--    -- Drop entries that equal the default, if there is a default-    dropDefault | Just l <- mbdef = M.filter (/= l)-                | otherwise       = id--    -- Check if the default is still needed-    defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1----- | Changes all labels mentioned in the SwitchTargets value-mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets-mapSwitchTargets f (SwitchTargets signed range mbdef branches)-    = SwitchTargets signed range (fmap f mbdef) (fmap f branches)---- | Returns the list of non-default branches of the SwitchTargets value-switchTargetsCases :: SwitchTargets -> [(Integer, Label)]-switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches---- | Return the default label of the SwitchTargets value-switchTargetsDefault :: SwitchTargets -> Maybe Label-switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef---- | Return the range of the SwitchTargets value-switchTargetsRange :: SwitchTargets -> (Integer, Integer)-switchTargetsRange (SwitchTargets _ range _ _) = range---- | Return whether this is used for a signed value-switchTargetsSigned :: SwitchTargets -> Bool-switchTargetsSigned (SwitchTargets signed _ _ _) = signed---- | switchTargetsToTable creates a dense jump table, usable for code generation.------ Also returns an offset to add to the value; the list is 0-based on the--- result of that addition.------ The conversion from Integer to Int is a bit of a wart, as the actual--- scrutinee might be an unsigned word, but it just works, due to wrap-around--- arithmetic (as verified by the CmmSwitchTest test case).-switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label])-switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches)-    = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ])-  where-    labelFor i = case M.lookup i branches of Just l -> Just l-                                             Nothing -> mbdef-    start | lo >= 0 && lo < minJumpTableOffset  = 0  -- See Note [Jump Table Offset]-          | otherwise                           = lo---- Note [Jump Table Offset]--- ~~~~~~~~~~~~~~~~~~~~~~~~------ Usually, the code for a jump table starting at x will first subtract x from--- the value, to avoid a large amount of empty entries. But if x is very small,--- the extra entries are no worse than the subtraction in terms of code size, and--- not having to do the subtraction is quicker.------ I.e. instead of---     _u20N:---             leaq -1(%r14),%rax---             jmp *_n20R(,%rax,8)---     _n20R:---             .quad   _c20p---             .quad   _c20q--- do---     _u20N:---             jmp *_n20Q(,%r14,8)------     _n20Q:---             .quad   0---             .quad   _c20p---             .quad   _c20q---             .quad   _c20r---- | The list of all labels occurring in the SwitchTargets value.-switchTargetsToList :: SwitchTargets -> [Label]-switchTargetsToList (SwitchTargets _ _ mbdef branches)-    = maybeToList mbdef ++ M.elems branches---- | Groups cases with equal targets, suitable for pretty-printing to a--- c-like switch statement with fall-through semantics.-switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)-switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)-  where-    groups = map (\xs -> (map fst xs, snd (head xs))) $-             groupBy ((==) `on` snd) $-             M.toList branches---- | Custom equality helper, needed for "CmmCommonBlockElim"-eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool-eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) =-    signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)-  where-    goMB Nothing Nothing = True-    goMB (Just l1) (Just l2) = l1 `eq` l2-    goMB _ _ = False-    goList [] [] = True-    goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2-    goList _ _ = False---------------------------------------------------------------------------------- Code generation for Switches----- | A SwitchPlan abstractly describes how a Switch statement ought to be--- implemented. See Note [createSwitchPlan]-data SwitchPlan-    = Unconditionally Label-    | IfEqual Integer Label SwitchPlan-    | IfLT Bool Integer SwitchPlan SwitchPlan-    | JumpTable SwitchTargets-  deriving Show------ Note [createSwitchPlan]--- ~~~~~~~~~~~~~~~~~~~~~~~------ A SwitchPlan describes how a Switch statement is to be broken down into--- smaller pieces suitable for code generation.------ createSwitchPlan creates such a switch plan, in these steps:---  1. It splits the switch statement at segments of non-default values that---     are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch]---  2. Too small jump tables should be avoided, so we break up smaller pieces---     in breakTooSmall.---  3. We fill in the segments between those pieces with a jump to the default---     label (if there is one), returning a SeparatedList in mkFlatSwitchPlan---  4. We find and replace two less-than branches by a single equal-to-test in---     findSingleValues---  5. The thus collected pieces are assembled to a balanced binary tree.--{--  Note [Two alts + default]-  ~~~~~~~~~~~~~~~~~~~~~~~~~--Discussion and a bit more info at #14644--When dealing with a switch of the form:-switch(e) {-  case 1: goto l1;-  case 3000: goto l2;-  default: goto ldef;-}--If we treat it as a sparse jump table we would generate:--if (e > 3000) //Check if value is outside of the jump table.-    goto ldef;-else {-    if (e < 3000) { //Compare to upper value-        if(e != 1) //Compare to remaining value-            goto ldef;-          else-            goto l2;-    }-    else-        goto l1;-}--Instead we special case this to :--if (e==1) goto l1;-else if (e==3000) goto l2;-else goto l3;--This means we have:-* Less comparisons for: 1,<3000-* Unchanged for 3000-* One more for >3000--This improves code in a few ways:-* One comparison less means smaller code which helps with cache.-* It exchanges a taken jump for two jumps no taken in the >range case.-  Jumps not taken are cheaper (See Agner guides) making this about as fast.-* For all other cases the first range check is removed making it faster.--The end result is that the change is not measurably slower for the case->3000 and faster for the other cases.--This makes running this kind of match in an inner loop cheaper by 10-20%-depending on the data.-In nofib this improves wheel-sieve1 by 4-9% depending on problem-size.--We could also add a second conditional jump after the comparison to-keep the range check like this:-    cmp 3000, rArgument-    jg <default>-    je <branch 2>-While this is fairly cheap it made no big difference for the >3000 case-and slowed down all other cases making it not worthwhile.--}----- | Does the target support switch out of the box? Then leave this to the--- target!-targetSupportsSwitch :: HscTarget -> Bool-targetSupportsSwitch HscC = True-targetSupportsSwitch HscLlvm = True-targetSupportsSwitch _ = False---- | This function creates a SwitchPlan from a SwitchTargets value, breaking it--- down into smaller pieces suitable for code generation.-createSwitchPlan :: SwitchTargets -> SwitchPlan--- Lets do the common case of a singleton map quicky and efficiently (#10677)-createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)-    | [(x, l)] <- M.toList m-    = IfEqual x l (Unconditionally defLabel)--- And another common case, matching "booleans"-createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)-    | [(x1, l1), (_x2,l2)] <- M.toAscList m-    --Checking If |range| = 2 is enough if we have two unique literals-    , hi - lo == 1-    = IfEqual x1 l1 (Unconditionally l2)--- See Note [Two alts + default]-createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)-    | [(x1, l1), (x2,l2)] <- M.toAscList m-    = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))-createSwitchPlan (SwitchTargets signed range mbdef m) =-    -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $-    plan-  where-    pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m-    flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces-    plan = buildTree signed $ flatPlan---------- Step 1: Splitting at large holes-----splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]-splitAtHoles _        m | M.null m = []-splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles-  where-    holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))-    nonHoles = reassocTuples lo holes hi--    (lo,_) = M.findMin m-    (hi,_) = M.findMax m--------- Step 2: Avoid small jump tables------- We do not want jump tables below a certain size. This breaks them up--- (into singleton maps, for now).-breakTooSmall :: M.Map Integer a -> [M.Map Integer a]-breakTooSmall m-  | M.size m > minJumpTableSize = [m]-  | otherwise                   = [M.singleton k v | (k,v) <- M.toList m]---------  Step 3: Fill in the blanks-------- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every--- two entries, dividing the range.--- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if--- the expression is < n, and plan2 otherwise.--type FlatSwitchPlan = SeparatedList Integer SwitchPlan--mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan---- If we have no default (i.e. undefined where there is no entry), we can--- branch at the minimum of each map-mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty-mkFlatSwitchPlan signed  Nothing _ (m:ms)-  = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ])---- If we have a default, we have to interleave segments that jump--- to the default between the maps-mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps)-  where-    go (lo,hi) []-        | lo > hi = []-        | otherwise = [(lo, Unconditionally l)]-    go (lo,hi) (m:ms)-        | lo < min-        = (lo, Unconditionally l) : go (min,hi) (m:ms)-        | lo == min-        = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms-        | otherwise-        = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min)-      where-        min = fst (M.findMin m)-        max = fst (M.findMax m)---mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan-mkLeafPlan signed mbdef m-    | [(_,l)] <- M.toList m -- singleton map-    = Unconditionally l-    | otherwise-    = JumpTable $ mkSwitchTargets signed (min,max) mbdef m-  where-    min = fst (M.findMin m)-    max = fst (M.findMax m)---------  Step 4: Reduce the number of branches using ==-------- A sequence of three unconditional jumps, with the outer two pointing to the--- same value and the bounds off by exactly one can be improved-findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan-findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs)-  | l == l3 && i + 1 == i'-  = findSingleValues (IfEqual i l2 (Unconditionally l), xs)-findSingleValues (p, (i,p'):xs)-  = (p,i) `consSL` findSingleValues (p', xs)-findSingleValues (p, [])-  = (p, [])---------  Step 5: Actually build the tree-------- Build a balanced tree from a separated list-buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan-buildTree _ (p,[]) = p-buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2)-  where-    (sl1, m, sl2) = divideSL sl--------- Utility data type: Non-empty lists with extra markers in between each--- element:-----type SeparatedList b a = (a, [(b,a)])--consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a-consSL (a, b) (a', xs) = (a, (b,a'):xs)--divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a)-divideSL (_,[]) = error "divideSL: Singleton SeparatedList"-divideSL (p,xs) = ((p, xs1), m, (p', xs2))-  where-    (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs------- Other Utilities-----restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b-restrictMap (lo,hi) m = mid-  where (_,   mid_hi) = M.split (lo-1) m-        (mid, _) =      M.split (hi+1) mid_hi---- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)]-reassocTuples :: a -> [(a,a)] -> a -> [(a,a)]-reassocTuples initial [] last-    = [(initial,last)]-reassocTuples initial ((a,b):tuples) last-    = (initial,a) : reassocTuples b tuples last---- Note [CmmSwitch vs. CmmImplementSwitchPlans]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- I (Joachim) separated the two somewhat closely related modules------  - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy---    for implementing a Cmm switch (createSwitchPlan), and---  - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification,------ for these reasons:------  * CmmSwitch is very low in the dependency tree, i.e. does not depend on any---    GHC specific modules at all (with the exception of Output and Hoople---    (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very---    high in the dependency tree.---  * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but---    used in CmmNodes.---  * Because CmmSwitch is low in the dependency tree, the separation allows---    for more parallelism when building GHC.---  * The interaction between the modules is very explicit and easy to---    understand, due to the small and simple interface.
− compiler/cmm/CmmUtils.hs 
@@ -1,607 +0,0 @@-{-# LANGUAGE GADTs, RankNTypes #-}-{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------------- Cmm utilities.------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module CmmUtils(-        -- CmmType-        primRepCmmType, slotCmmType, slotForeignHint,-        typeCmmType, typeForeignHint, primRepForeignHint,--        -- CmmLit-        zeroCLit, mkIntCLit,-        mkWordCLit, packHalfWordsCLit,-        mkByteStringCLit,-        mkDataLits, mkRODataLits,-        mkStgWordCLit,--        -- CmmExpr-        mkIntExpr, zeroExpr,-        mkLblExpr,-        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,-        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,-        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,-        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,-        cmmNegate,-        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,-        cmmSLtWord,-        cmmNeWord, cmmEqWord,-        cmmOrWord, cmmAndWord,-        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,-        cmmToWord,--        cmmMkAssign,--        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,--        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,-        currentTSOExpr, currentNurseryExpr, cccsExpr,--        -- Statics-        blankWord,--        -- Tagging-        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,-        cmmConstrTag1,--        -- Overlap and usage-        regsOverlap, regUsedIn,--        -- Liveness and bitmaps-        mkLiveness,--        -- * Operations that probably don't belong here-        modifyGraph,--        ofBlockMap, toBlockMap,-        ofBlockList, toBlockList, bodyToBlockList,-        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,-        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,--        -- * Ticks-        blockTicks-  ) where--import GhcPrelude--import TyCon    ( PrimRep(..), PrimElemRep(..) )-import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )--import SMRep-import Cmm-import BlockId-import CLabel-import Outputable-import DynFlags-import Unique-import GHC.Platform.Regs--import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Bits-import Hoopl.Graph-import Hoopl.Label-import Hoopl.Block-import Hoopl.Collections-----------------------------------------------------------      CmmTypes---------------------------------------------------------primRepCmmType :: DynFlags -> PrimRep -> CmmType-primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"-primRepCmmType dflags LiftedRep        = gcWord dflags-primRepCmmType dflags UnliftedRep      = gcWord dflags-primRepCmmType dflags IntRep           = bWord dflags-primRepCmmType dflags WordRep          = bWord dflags-primRepCmmType _      Int8Rep          = b8-primRepCmmType _      Word8Rep         = b8-primRepCmmType _      Int16Rep         = b16-primRepCmmType _      Word16Rep        = b16-primRepCmmType _      Int32Rep         = b32-primRepCmmType _      Word32Rep        = b32-primRepCmmType _      Int64Rep         = b64-primRepCmmType _      Word64Rep        = b64-primRepCmmType dflags AddrRep          = bWord dflags-primRepCmmType _      FloatRep         = f32-primRepCmmType _      DoubleRep        = f64-primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)--slotCmmType :: DynFlags -> SlotTy -> CmmType-slotCmmType dflags PtrSlot    = gcWord dflags-slotCmmType dflags WordSlot   = bWord dflags-slotCmmType _      Word64Slot = b64-slotCmmType _      FloatSlot  = f32-slotCmmType _      DoubleSlot = f64--primElemRepCmmType :: PrimElemRep -> CmmType-primElemRepCmmType Int8ElemRep   = b8-primElemRepCmmType Int16ElemRep  = b16-primElemRepCmmType Int32ElemRep  = b32-primElemRepCmmType Int64ElemRep  = b64-primElemRepCmmType Word8ElemRep  = b8-primElemRepCmmType Word16ElemRep = b16-primElemRepCmmType Word32ElemRep = b32-primElemRepCmmType Word64ElemRep = b64-primElemRepCmmType FloatElemRep  = f32-primElemRepCmmType DoubleElemRep = f64--typeCmmType :: DynFlags -> UnaryType -> CmmType-typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)--primRepForeignHint :: PrimRep -> ForeignHint-primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"-primRepForeignHint LiftedRep    = AddrHint-primRepForeignHint UnliftedRep  = AddrHint-primRepForeignHint IntRep       = SignedHint-primRepForeignHint Int8Rep      = SignedHint-primRepForeignHint Int16Rep     = SignedHint-primRepForeignHint Int32Rep     = SignedHint-primRepForeignHint Int64Rep     = SignedHint-primRepForeignHint WordRep      = NoHint-primRepForeignHint Word8Rep     = NoHint-primRepForeignHint Word16Rep    = NoHint-primRepForeignHint Word32Rep    = NoHint-primRepForeignHint Word64Rep    = NoHint-primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg-primRepForeignHint FloatRep     = NoHint-primRepForeignHint DoubleRep    = NoHint-primRepForeignHint (VecRep {})  = NoHint--slotForeignHint :: SlotTy -> ForeignHint-slotForeignHint PtrSlot       = AddrHint-slotForeignHint WordSlot      = NoHint-slotForeignHint Word64Slot    = NoHint-slotForeignHint FloatSlot     = NoHint-slotForeignHint DoubleSlot    = NoHint--typeForeignHint :: UnaryType -> ForeignHint-typeForeignHint = primRepForeignHint . typePrimRep1-----------------------------------------------------------      CmmLit----------------------------------------------------------- XXX: should really be Integer, since Int doesn't necessarily cover--- the full range of target Ints.-mkIntCLit :: DynFlags -> Int -> CmmLit-mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)--mkIntExpr :: DynFlags -> Int -> CmmExpr-mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i--zeroCLit :: DynFlags -> CmmLit-zeroCLit dflags = CmmInt 0 (wordWidth dflags)--zeroExpr :: DynFlags -> CmmExpr-zeroExpr dflags = CmmLit (zeroCLit dflags)--mkWordCLit :: DynFlags -> Integer -> CmmLit-mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)--mkByteStringCLit-  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)--- We have to make a top-level decl for the string,--- and return a literal pointing to it-mkByteStringCLit lbl bytes-  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])-  where-    -- This can not happen for String literals (as there \NUL is replaced by-    -- C0 80). However, it can happen with Addr# literals.-    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString--mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt--- Build a data-segment data block-mkDataLits section lbl lits-  = CmmData section (Statics lbl $ map CmmStaticLit lits)--mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt--- Build a read-only data block-mkRODataLits lbl lits-  = mkDataLits section lbl lits-  where-    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl-            | otherwise                = Section ReadOnlyData lbl-    needsRelocation (CmmLabel _)      = True-    needsRelocation (CmmLabelOff _ _) = True-    needsRelocation _                 = False--mkStgWordCLit :: DynFlags -> StgWord -> CmmLit-mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)--packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit--- Make a single word literal in which the lower_half_word is--- at the lower address, and the upper_half_word is at the--- higher address--- ToDo: consider using half-word lits instead---       but be careful: that's vulnerable when reversed-packHalfWordsCLit dflags lower_half_word upper_half_word-   = if wORDS_BIGENDIAN dflags-     then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)-     else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags))-    where l = fromStgHalfWord lower_half_word-          u = fromStgHalfWord upper_half_word-----------------------------------------------------------      CmmExpr---------------------------------------------------------mkLblExpr :: CLabel -> CmmExpr-mkLblExpr lbl = CmmLit (CmmLabel lbl)--cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr--- assumes base and offset have the same CmmType-cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)-cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]--cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr-cmmOffset _ e                 0        = e-cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off-cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)-cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)-cmmOffset _ (CmmStackSlot area off) byte_off-  = CmmStackSlot area (off - byte_off)-  -- note stack area offsets increase towards lower addresses-cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2-  = CmmMachOp (MO_Add rep)-              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]-cmmOffset dflags expr byte_off-  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]-  where-    width = cmmExprWidth dflags expr---- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.-cmmRegOff :: CmmReg -> Int -> CmmExpr-cmmRegOff reg 0        = CmmReg reg-cmmRegOff reg byte_off = CmmRegOff reg byte_off--cmmOffsetLit :: CmmLit -> Int -> CmmLit-cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off-cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)-cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off-                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w-cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep-cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)--cmmLabelOff :: CLabel -> Int -> CmmLit--- Smart constructor for CmmLabelOff-cmmLabelOff lbl 0        = CmmLabel lbl-cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off---- | Useful for creating an index into an array, with a statically known offset.--- The type is the element type; used for making the multiplier-cmmIndex :: DynFlags-         -> Width       -- Width w-         -> CmmExpr     -- Address of vector of items of width w-         -> Int         -- Which element of the vector (0 based)-         -> CmmExpr     -- Address of i'th element-cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)---- | Useful for creating an index into an array, with an unknown offset.-cmmIndexExpr :: DynFlags-             -> Width           -- Width w-             -> CmmExpr         -- Address of vector of items of width w-             -> CmmExpr         -- Which element of the vector (0 based)-             -> CmmExpr         -- Address of i'th element-cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)-cmmIndexExpr dflags width base idx =-  cmmOffsetExpr dflags base byte_off-  where-    idx_w = cmmExprWidth dflags idx-    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]--cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr-cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty---- The "B" variants take byte offsets-cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr-cmmRegOffB = cmmRegOff--cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr-cmmOffsetB = cmmOffset--cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr-cmmOffsetExprB = cmmOffsetExpr--cmmLabelOffB :: CLabel -> ByteOff -> CmmLit-cmmLabelOffB = cmmLabelOff--cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit-cmmOffsetLitB = cmmOffsetLit---------------------------- The "W" variants take word offsets--cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr--- The second arg is a *word* offset; need to change it to bytes-cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)-cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off--cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr-cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)--cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr-cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)--cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit-cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)--cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit-cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)--cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr-cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty--------------------------cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,-  cmmSLtWord,-  cmmNeWord, cmmEqWord,-  cmmOrWord, cmmAndWord,-  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord-  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr-cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]-cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]-cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]-cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]-cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]-cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]-cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]-cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]-cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]-cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]-cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]-cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]-cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]--cmmNegate :: DynFlags -> CmmExpr -> CmmExpr-cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)-cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]--blankWord :: DynFlags -> CmmStatic-blankWord dflags = CmmUninitialised (wORD_SIZE dflags)--cmmToWord :: DynFlags -> CmmExpr -> CmmExpr-cmmToWord dflags e-  | w == word  = e-  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]-  where-    w = cmmExprWidth dflags e-    word = wordWidth dflags--cmmMkAssign :: DynFlags -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)-cmmMkAssign dflags expr uq =-  let !ty = cmmExprType dflags expr-      reg = (CmmLocal (LocalReg uq ty))-  in  (CmmAssign reg expr, CmmReg reg)------------------------------------------------------------      CmmExpr predicates---------------------------------------------------------isTrivialCmmExpr :: CmmExpr -> Bool-isTrivialCmmExpr (CmmLoad _ _)      = False-isTrivialCmmExpr (CmmMachOp _ _)    = False-isTrivialCmmExpr (CmmLit _)         = True-isTrivialCmmExpr (CmmReg _)         = True-isTrivialCmmExpr (CmmRegOff _ _)    = True-isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"--hasNoGlobalRegs :: CmmExpr -> Bool-hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e-hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es-hasNoGlobalRegs (CmmLit _)                 = True-hasNoGlobalRegs (CmmReg (CmmLocal _))      = True-hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True-hasNoGlobalRegs _ = False--isLit :: CmmExpr -> Bool-isLit (CmmLit _) = True-isLit _          = False--isComparisonExpr :: CmmExpr -> Bool-isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op-isComparisonExpr _                  = False-----------------------------------------------------------      Tagging----------------------------------------------------------- Tag bits mask-cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr-cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)-cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))---- Used to untag a possibly tagged pointer--- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr-cmmUntag _ e@(CmmLit (CmmLabel _)) = e--- Default case-cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)---- Test if a closure pointer is untagged-cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)---- Get constructor tag, but one based.-cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)----------------------------------------------------------------------------------- Overlap and usage---- | Returns True if the two STG registers overlap on the specified--- platform, in the sense that writing to one will clobber the--- other. This includes the case that the two registers are the same--- STG register. See Note [Overlapping global registers] for details.-regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool-regsOverlap dflags (CmmGlobal g) (CmmGlobal g')-  | Just real  <- globalRegMaybe (targetPlatform dflags) g,-    Just real' <- globalRegMaybe (targetPlatform dflags) g',-    real == real'-    = True-regsOverlap _ reg reg' = reg == reg'---- | Returns True if the STG register is used by the expression, in--- the sense that a store to the register might affect the value of--- the expression.------ We must check for overlapping registers and not just equal--- registers here, otherwise CmmSink may incorrectly reorder--- assignments that conflict due to overlap. See #10521 and Note--- [Overlapping global registers].-regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool-regUsedIn dflags = regUsedIn_ where-  _   `regUsedIn_` CmmLit _         = False-  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e-  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'-  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'-  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es-  _   `regUsedIn_` CmmStackSlot _ _ = False----------------------------------------------------        mkLiveness---------------------------------------------------mkLiveness :: DynFlags -> [LocalReg] -> Liveness-mkLiveness _      [] = []-mkLiveness dflags (reg:regs)-  = bits ++ mkLiveness dflags regs-  where-    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)-            `quot` wORD_SIZE dflags-            -- number of words, rounded up-    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr--    is_non_ptr = not $ isGcPtrType (localRegType reg)----- ============================================== ---- ============================================== ---- ============================================== ------------------------------------------------------------      Manipulating CmmGraphs---------------------------------------------------------modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'-modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}--toBlockMap :: CmmGraph -> LabelMap CmmBlock-toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body--ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph-ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}--toBlockList :: CmmGraph -> [CmmBlock]-toBlockList g = mapElems $ toBlockMap g---- | like 'toBlockList', but the entry block always comes first-toBlockListEntryFirst :: CmmGraph -> [CmmBlock]-toBlockListEntryFirst g-  | mapNull m  = []-  | otherwise  = entry_block : others-  where-    m = toBlockMap g-    entry_id = g_entry g-    Just entry_block = mapLookup entry_id m-    others = filter ((/= entry_id) . entryLabel) (mapElems m)---- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks--- so that the false case of a conditional jumps to the next block in the output--- list of blocks. This matches the way OldCmm blocks were output since in--- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches--- have both true and false successors. Block ordering can make a big difference--- in performance in the LLVM backend. Note that we rely crucially on the order--- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode--- defined in cmm/CmmNode.hs. -GBM-toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]-toBlockListEntryFirstFalseFallthrough g-  | mapNull m  = []-  | otherwise  = dfs setEmpty [entry_block]-  where-    m = toBlockMap g-    entry_id = g_entry g-    Just entry_block = mapLookup entry_id m--    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]-    dfs _ [] = []-    dfs visited (block:bs)-      | id `setMember` visited = dfs visited bs-      | otherwise              = block : dfs (setInsert id visited) bs'-      where id = entryLabel block-            bs' = foldr add_id bs (successors block)-            add_id id bs = case mapLookup id m of-                              Just b  -> b : bs-                              Nothing -> bs--ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph-ofBlockList entry blocks = CmmGraph { g_entry = entry-                                    , g_graph = GMany NothingO body NothingO }-  where body = foldr addBlock emptyBody blocks--bodyToBlockList :: Body CmmNode -> [CmmBlock]-bodyToBlockList body = mapElems body--mapGraphNodes :: ( CmmNode C O -> CmmNode C O-                 , CmmNode O O -> CmmNode O O-                 , CmmNode O C -> CmmNode O C)-              -> CmmGraph -> CmmGraph-mapGraphNodes funs@(mf,_,_) g =-  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $-  mapMap (mapBlock3' funs) $ toBlockMap g--mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph-mapGraphNodes1 f = modifyGraph (mapGraph f)---foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a-foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g--revPostorder :: CmmGraph -> [CmmBlock]-revPostorder g = {-# SCC "revPostorder" #-}-    revPostorderFrom (toBlockMap g) (g_entry g)------------------------------------------------------ Tick utilities---- | Extract all tick annotations from the given block-blockTicks :: Block CmmNode C C -> [CmmTickish]-blockTicks b = reverse $ foldBlockNodesF goStmt b []-  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]-        goStmt  (CmmTick t) ts = t:ts-        goStmt  _other      ts = ts----- -------------------------------------------------------------------------------- Access to common global registers--baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,-  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr-baseExpr = CmmReg baseReg-spExpr = CmmReg spReg-spLimExpr = CmmReg spLimReg-hpExpr = CmmReg hpReg-hpLimExpr = CmmReg hpLimReg-currentTSOExpr = CmmReg currentTSOReg-currentNurseryExpr = CmmReg currentNurseryReg-cccsExpr = CmmReg cccsReg
− compiler/cmm/Debug.hs 
@@ -1,546 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiWayIf #-}------------------------------------------------------------------------------------- Debugging data------ Association of debug data on the Cmm level, with methods to encode it in--- event log format for later inclusion in profiling event logs.-----------------------------------------------------------------------------------module Debug (--  DebugBlock(..),-  cmmDebugGen,-  cmmDebugLabels,-  cmmDebugLink,-  debugToMap,--  -- * Unwinding information-  UnwindTable, UnwindPoint(..),-  UnwindExpr(..), toUnwindExpr-  ) where--import GhcPrelude--import BlockId-import CLabel-import Cmm-import CmmUtils-import CoreSyn-import FastString      ( nilFS, mkFastString )-import Module-import Outputable-import PprCmmExpr      ( pprExpr )-import SrcLoc-import Util            ( seqList )--import Hoopl.Block-import Hoopl.Collections-import Hoopl.Graph-import Hoopl.Label--import Data.Maybe-import Data.List     ( minimumBy, nubBy )-import Data.Ord      ( comparing )-import qualified Data.Map as Map-import Data.Either   ( partitionEithers )---- | Debug information about a block of code. Ticks scope over nested--- blocks.-data DebugBlock =-  DebugBlock-  { dblProcedure  :: !Label        -- ^ Entry label of containing proc-  , dblLabel      :: !Label        -- ^ Hoopl label-  , dblCLabel     :: !CLabel       -- ^ Output label-  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?-  , dblParent     :: !(Maybe DebugBlock)-    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]-  , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block-  , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block-  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to-                                   -- other blocks. @Nothing@ means-                                   -- the block was optimized out-  , dblUnwind     :: [UnwindPoint]-  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks-  }--instance Outputable DebugBlock where-  ppr blk = (if | dblProcedure blk == dblLabel blk-                -> text "proc"-                | dblHasInfoTbl blk-                -> text "pp-blk"-                | otherwise-                -> text "blk") <+>-            ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>-            (maybe empty ppr (dblSourceTick blk)) <+>-            (maybe (text "removed") ((text "pos " <>) . ppr)-                   (dblPosition blk)) <+>-            (ppr (dblUnwind blk)) $+$-            (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))---- | Intermediate data structure holding debug-relevant context information--- about a block.-type BlockContext = (CmmBlock, RawCmmDecl)---- | Extract debug data from a group of procedures. We will prefer--- source notes that come from the given module (presumably the module--- that we are currently compiling).-cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]-cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes-  where-      blockCtxs :: Map.Map CmmTickScope [BlockContext]-      blockCtxs = blockContexts decls--      -- Analyse tick scope structure: Each one is either a top-level-      -- tick scope, or the child of another.-      (topScopes, childScopes)-        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs-      findP tsc GlobalScope = Left tsc -- top scope-      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)-                    | otherwise                   = findP tsc scp'-        where -- Note that we only following the left parent of-              -- combined scopes. This loses us ticks, which we will-              -- recover by copying ticks below.-              scp' | SubScope _ scp' <- scp      = scp'-                   | CombinedScope scp' _ <- scp = scp'-                   | otherwise                   = panic "findP impossible"--      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes--      -- This allows us to recover ticks that we lost by flattening-      -- the graph. Basically, if the parent is A but the child is-      -- CBA, we know that there is no BA, because it would have taken-      -- priority - but there might be a B scope, with ticks that-      -- would not be associated with our child anymore. Note however-      -- that there might be other childs (DB), which we have to-      -- filter out.-      ---      -- We expect this to be called rarely, which is why we are not-      -- trying too hard to be efficient here. In many cases we won't-      -- have to construct blockCtxsU in the first place.-      ticksToCopy :: CmmTickScope -> [CmmTickish]-      ticksToCopy (CombinedScope scp s) = go s-        where go s | scp `isTickSubScope` s   = [] -- done-                   | SubScope _ s' <- s       = ticks ++ go s'-                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2-                   | otherwise                = panic "ticksToCopy impossible"-                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs-      ticksToCopy _ = []-      bCtxsTicks = concatMap (blockTicks . fst)--      -- Finding the "best" source tick is somewhat arbitrary -- we-      -- select the first source span, while preferring source ticks-      -- from the same source file.  Furthermore, dumps take priority-      -- (if we generated one, we probably want debug information to-      -- refer to it).-      bestSrcTick = minimumBy (comparing rangeRating)-      rangeRating (SourceNote span _)-        | srcSpanFile span == thisFile = 1-        | otherwise                    = 2 :: Int-      rangeRating note                 = pprPanic "rangeRating" (ppr note)-      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc--      -- Returns block tree for this scope as well as all nested-      -- scopes. Note that if there are multiple blocks in the (exact)-      -- same scope we elect one as the "branch" node and add the rest-      -- as children.-      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock-      blocksForScope cstick scope = mkBlock True (head bctxs)-        where bctxs = fromJust $ Map.lookup scope blockCtxs-              nested = fromMaybe [] $ Map.lookup scope scopeMap-              childs = map (mkBlock False) (tail bctxs) ++-                       map (blocksForScope stick) nested--              mkBlock :: Bool -> BlockContext -> DebugBlock-              mkBlock top (block, prc)-                = DebugBlock { dblProcedure    = g_entry graph-                             , dblLabel        = label-                             , dblCLabel       = case info of-                                 Just (Statics infoLbl _)   -> infoLbl-                                 Nothing-                                   | g_entry graph == label -> entryLbl-                                   | otherwise              -> blockLbl label-                             , dblHasInfoTbl   = isJust info-                             , dblParent       = Nothing-                             , dblTicks        = ticks-                             , dblPosition     = Nothing -- see cmmDebugLink-                             , dblSourceTick   = stick-                             , dblBlocks       = blocks-                             , dblUnwind       = []-                             }-                where (CmmProc infos entryLbl _ graph) = prc-                      label = entryLabel block-                      info = mapLookup label infos-                      blocks | top       = seqList childs childs-                             | otherwise = []--              -- A source tick scopes over all nested blocks. However-              -- their source ticks might take priority.-              isSourceTick SourceNote {} = True-              isSourceTick _             = False-              -- Collect ticks from all blocks inside the tick scope.-              -- We attempt to filter out duplicates while we're at it.-              ticks = nubBy (flip tickishContains) $-                      bCtxsTicks bctxs ++ ticksToCopy scope-              stick = case filter isSourceTick ticks of-                []     -> cstick-                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)---- | Build a map of blocks sorted by their tick scopes------ This involves a pre-order traversal, as we want blocks in rough--- control flow order (so ticks have a chance to be sorted in the--- right order).-blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]-blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls-  where walkProc :: RawCmmDecl-                 -> Map.Map CmmTickScope [BlockContext]-                 -> Map.Map CmmTickScope [BlockContext]-        walkProc CmmData{}                 m = m-        walkProc prc@(CmmProc _ _ _ graph) m-          | mapNull blocks = m-          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)-          where blocks = toBlockMap graph-                entry  = [mapFind (g_entry graph) blocks]-                emptyLbls = setEmpty :: LabelSet--        walkBlock :: RawCmmDecl -> [Block CmmNode C C]-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])-        walkBlock _   []             c            = c-        walkBlock prc (block:blocks) (visited, m)-          | lbl `setMember` visited-          = walkBlock prc blocks (visited, m)-          | otherwise-          = walkBlock prc blocks $-            walkBlock prc succs-              (lbl `setInsert` visited,-               insertMulti scope (block, prc) m)-          where CmmEntry lbl scope = firstNode block-                (CmmProc _ _ _ graph) = prc-                succs = map (flip mapFind (toBlockMap graph))-                            (successors (lastNode block))-        mapFind = mapFindWithDefault (error "contextTree: block not found!")--insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]-insertMulti k v = Map.insertWith (const (v:)) k [v]--cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]-cmmDebugLabels isMeta nats = seqList lbls lbls-  where -- Find order in which procedures will be generated by the-        -- back-end (that actually matters for DWARF generation).-        ---        -- Note that we might encounter blocks that are missing or only-        -- consist of meta instructions -- we will declare them missing,-        -- which will skip debug data generation without messing up the-        -- block hierarchy.-        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats-        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs-        getBlocks _other                         = []-        allMeta (BasicBlock _ instrs) = all isMeta instrs---- | Sets position and unwind table fields in the debug block tree according to--- native generated code.-cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]-             -> [DebugBlock] -> [DebugBlock]-cmmDebugLink labels unwindPts blocks = map link blocks-  where blockPos :: LabelMap Int-        blockPos = mapFromList $ flip zip [0..] labels-        link block = block { dblPosition = mapLookup (dblLabel block) blockPos-                           , dblBlocks   = map link (dblBlocks block)-                           , dblUnwind   = fromMaybe mempty-                                         $ mapLookup (dblLabel block) unwindPts-                           }---- | Converts debug blocks into a label map for easier lookups-debugToMap :: [DebugBlock] -> LabelMap DebugBlock-debugToMap = mapUnions . map go-   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)--{--Note [What is this unwinding business?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Unwinding tables are a variety of debugging information used by debugging tools-to reconstruct the execution history of a program at runtime. These tables-consist of sets of "instructions", one set for every instruction in the program,-which describe how to reconstruct the state of the machine at the point where-the current procedure was called. For instance, consider the following annotated-pseudo-code,--  a_fun:-    add rsp, 8            -- unwind: rsp = rsp - 8-    mov rax, 1            -- unwind: rax = unknown-    call another_block-    sub rsp, 8            -- unwind: rsp = rsp--We see that attached to each instruction there is an "unwind" annotation, which-provides a relationship between each updated register and its value at the-time of entry to a_fun. This is the sort of information that allows gdb to give-you a stack backtrace given the execution state of your program. This-unwinding information is captured in various ways by various debug information-formats; in the case of DWARF (the only format supported by GHC) it is known as-Call Frame Information (CFI) and can be found in the .debug.frames section of-your object files.--Currently we only bother to produce unwinding information for registers which-are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp-(which is the STG stack pointer) and $rsp (the C stack pointer).--Let's consider how GHC would annotate a C-- program with unwinding information-with a typical C-- procedure as would come from the STG-to-Cmm code generator,--  entry()-     { c2fe:-           v :: P64 = R2;-           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;-       c2ff:-           R2 = v :: P64;-           R1 = test_closure;-           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;-       c2fg:-           I64[Sp - 8] = c2dD;-           R1 = v :: P64;-           Sp = Sp - 8;          // Sp updated here-           if (R1 & 7 != 0) goto c2dD; else goto c2dE;-       c2dE:-           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;-       c2dD:-           w :: P64 = R1;-           Hp = Hp + 48;-           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;-       ...-  },--Let's consider how this procedure will be decorated with unwind information-(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the-value of Sp is no different from what it was at its call site. Therefore we will-add an `unwind` statement saying this at the beginning of its unwind-annotated-code,--  entry()-     { c2fe:-           unwind Sp = Just Sp + 0;-           v :: P64 = R2;-           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;--After c2fe we may pass to either c2ff or c2fg; let's first consider the-former. In this case there is nothing in particular that we need to do other-than reiterate what we already know about Sp,--       c2ff:-           unwind Sp = Just Sp + 0;-           R2 = v :: P64;-           R1 = test_closure;-           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;--In contrast, c2fg updates Sp midway through its body. To ensure that unwinding-can happen correctly after this point we must include an unwind statement there,-in addition to the usual beginning-of-block statement,--       c2fg:-           unwind Sp = Just Sp + 0;-           I64[Sp - 8] = c2dD;-           R1 = v :: P64;-           Sp = Sp - 8;-           unwind Sp = Just Sp + 8;-           if (R1 & 7 != 0) goto c2dD; else goto c2dE;--The remaining blocks are simple,--       c2dE:-           unwind Sp = Just Sp + 8;-           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;-       c2dD:-           unwind Sp = Just Sp + 8;-           w :: P64 = R1;-           Hp = Hp + 48;-           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;-       ...-  },---The flow of unwinding information through the compiler is a bit convoluted:-- * C-- begins life in StgToCmm without any unwind information. This is because we-   haven't actually done any register assignment or stack layout yet, so there-   is no need for unwind information.-- * CmmLayoutStack figures out how to layout each procedure's stack, and produces-   appropriate unwinding nodes for each adjustment of the STG Sp register.-- * The unwind nodes are carried through the sinking pass. Currently this is-   guaranteed not to invalidate unwind information since it won't touch stores-   to Sp, but this will need revisiting if CmmSink gets smarter in the future.-- * Eventually we make it to the native code generator backend which can then-   preserve the unwind nodes in its machine-specific instructions. In so doing-   the backend can also modify or add unwinding information; this is necessary,-   for instance, in the case of x86-64, where adjustment of $rsp may be-   necessary during calls to native foreign code due to the native calling-   convention.-- * The NCG then retrieves the final unwinding table for each block from the-   backend with extractUnwindPoints.-- * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen-- * These DebugBlocks are then converted to, e.g., DWARF unwinding tables-   (by the Dwarf module) and emitted in the final object.--See also:-  Note [Unwinding information in the NCG] in AsmCodeGen,-  Note [Unwind pseudo-instruction in Cmm],-  Note [Debugging DWARF unwinding info].---Note [Debugging DWARF unwinding info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--For debugging generated unwinding info I've found it most useful to dump the-disassembled binary with objdump -D and dump the debug info with-readelf --debug-dump=frames-interp.--You should get something like this:--  0000000000000010 <stg_catch_frame_info>:-    10:   48 83 c5 18             add    $0x18,%rbp-    14:   ff 65 00                jmpq   *0x0(%rbp)--and:--  Contents of the .debug_frame section:--  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16-     LOC           CFA      rbp   rsp   ra-  0000000000000000 rbp+0    v+0   s     c+0--  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017-     LOC           CFA      rbp   rsp   ra-  000000000000000f rbp+0    v+0   s     c+0-  000000000000000f rbp+24   v+0   s     c+0--To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in-Appendix 5 (page 101 of the pdf) and more details in the relevant section.--The key thing to keep in mind is that the value at LOC is the value from-*before* the instruction at LOC executes. In other words it answers the-question: if my $rip is at LOC, how do I get the relevant values given the-values obtained through unwinding so far.--If the readelf --debug-dump=frames-interp output looks wrong, it may also be-useful to look at readelf --debug-dump=frames, which is closer to the-information that GHC generated.--It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm--ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]-explains how to interpret it.--Inside gdb there are a couple useful commands for inspecting frames.-For example:--  gdb> info frame <num>--It shows the values of registers obtained through unwinding.--Another useful thing to try when debugging the DWARF unwinding is to enable-extra debugging output in GDB:--  gdb> set debug frame 1--This makes GDB produce a trace of its internal workings. Having gone this far,-it's just a tiny step to run GDB in GDB. Make sure you install debugging-symbols for gdb if you obtain it through a package manager.--Keep in mind that the current release of GDB has an instruction pointer handling-heuristic that works well for C-like languages, but doesn't always work for-Haskell. See Note [Info Offset] in Dwarf.Types for more details.--Note [Unwind pseudo-instruction in Cmm]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't-generate any assembly, but controls what DWARF unwinding information gets-generated.--It's important to understand what ranges of code the unwind pseudo-instruction-refers to.-For a sequence of CmmNodes like:--  A // starts at addr X and ends at addr Y-1-  unwind Sp = Just Sp + 16;-  B // starts at addr Y and ends at addr Z--the unwind statement reflects the state after A has executed, but before B-has executed. If you consult the Note [Debugging DWARF unwinding info], the-LOC this information will end up in is Y.--}---- | A label associated with an 'UnwindTable'-data UnwindPoint = UnwindPoint !CLabel !UnwindTable--instance Outputable UnwindPoint where-  ppr (UnwindPoint lbl uws) =-      braces $ ppr lbl<>colon-      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)-    where-      pprUw (g, expr) = ppr g <> char '=' <> ppr expr---- | Maps registers to expressions that yield their "old" values--- further up the stack. Most interesting for the stack pointer @Sp@,--- but might be useful to document saved registers, too. Note that a--- register's value will be 'Nothing' when the register's previous--- value cannot be reconstructed.-type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)---- | Expressions, used for unwind information-data UnwindExpr = UwConst !Int                  -- ^ literal value-                | UwReg !GlobalReg !Int         -- ^ register plus offset-                | UwDeref UnwindExpr            -- ^ pointer dereferencing-                | UwLabel CLabel-                | UwPlus UnwindExpr UnwindExpr-                | UwMinus UnwindExpr UnwindExpr-                | UwTimes UnwindExpr UnwindExpr-                deriving (Eq)--instance Outputable UnwindExpr where-  pprPrec _ (UwConst i)     = ppr i-  pprPrec _ (UwReg g 0)     = ppr g-  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))-  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e-  pprPrec _ (UwLabel l)     = pprPrec 3 l-  pprPrec p (UwPlus e0 e1)  | p <= 0-                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1-  pprPrec p (UwMinus e0 e1) | p <= 0-                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1-  pprPrec p (UwTimes e0 e1) | p <= 1-                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1-  pprPrec _ other           = parens (pprPrec 0 other)---- | Conversion of Cmm expressions to unwind expressions. We check for--- unsupported operator usages and simplify the expression as far as--- possible.-toUnwindExpr :: CmmExpr -> UnwindExpr-toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)-toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l-toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i-toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0-toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)-toUnwindExpr e@(CmmMachOp op [e1, e2])   =-  case (op, toUnwindExpr e1, toUnwindExpr e2) of-    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)-    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)-    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)-    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)-    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)-    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)-    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2-    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2-    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2-    _otherwise -> pprPanic "Unsupported operator in unwind expression!"-                           (pprExpr e)-toUnwindExpr e-  = pprPanic "Unsupported unwind expression!" (ppr e)
− compiler/cmm/Hoopl/Block.hs 
@@ -1,329 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-module Hoopl.Block-    ( Extensibility (..)-    , O-    , C-    , MaybeO(..)-    , IndexedCO-    , Block(..)-    , blockAppend-    , blockCons-    , blockFromList-    , blockJoin-    , blockJoinHead-    , blockJoinTail-    , blockSnoc-    , blockSplit-    , blockSplitHead-    , blockSplitTail-    , blockToList-    , emptyBlock-    , firstNode-    , foldBlockNodesB-    , foldBlockNodesB3-    , foldBlockNodesF-    , isEmptyBlock-    , lastNode-    , mapBlock-    , mapBlock'-    , mapBlock3'-    , replaceFirstNode-    , replaceLastNode-    ) where--import GhcPrelude---- -------------------------------------------------------------------------------- Shapes: Open and Closed---- | Used at the type level to indicate "open" vs "closed" structure.-data Extensibility-  -- | An "open" structure with a unique, unnamed control-flow edge flowing in-  -- or out. "Fallthrough" and concatenation are permitted at an open point.-  = Open-  -- | A "closed" structure which supports control transfer only through the use-  -- of named labels---no "fallthrough" is permitted. The number of control-flow-  -- edges is unconstrained.-  | Closed--type O = 'Open-type C = 'Closed---- | Either type indexed by closed/open using type families-type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k-type instance IndexedCO C a _b = a-type instance IndexedCO O _a b = b---- | Maybe type indexed by open/closed-data MaybeO ex t where-  JustO    :: t -> MaybeO O t-  NothingO ::      MaybeO C t---- | Maybe type indexed by closed/open-data MaybeC ex t where-  JustC    :: t -> MaybeC C t-  NothingC ::      MaybeC O t--deriving instance Functor (MaybeO ex)-deriving instance Functor (MaybeC ex)---- -------------------------------------------------------------------------------- The Block type---- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).--- Open at the entry means single entry, mutatis mutandis for exit.--- A closed/closed block is a /basic/ block and can't be extended further.--- Clients should avoid manipulating blocks and should stick to either nodes--- or graphs.-data Block n e x where-  BlockCO  :: n C O -> Block n O O          -> Block n C O-  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C-  BlockOC  ::          Block n O O -> n O C -> Block n O C--  BNil    :: Block n O O-  BMiddle :: n O O                      -> Block n O O-  BCat    :: Block n O O -> Block n O O -> Block n O O-  BSnoc   :: Block n O O -> n O O       -> Block n O O-  BCons   :: n O O       -> Block n O O -> Block n O O----- -------------------------------------------------------------------------------- Simple operations on Blocks---- Predicates--isEmptyBlock :: Block n e x -> Bool-isEmptyBlock BNil       = True-isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r-isEmptyBlock _          = False----- Building--emptyBlock :: Block n O O-emptyBlock = BNil--blockCons :: n O O -> Block n O x -> Block n O x-blockCons n b = case b of-  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l-  BNil{}    -> BMiddle n-  BMiddle{} -> n `BCons` b-  BCat{}    -> n `BCons` b-  BSnoc{}   -> n `BCons` b-  BCons{}   -> n `BCons` b--blockSnoc :: Block n e O -> n O O -> Block n e O-blockSnoc b n = case b of-  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)-  BNil{}      -> BMiddle n-  BMiddle{}   -> b `BSnoc` n-  BCat{}      -> b `BSnoc` n-  BSnoc{}     -> b `BSnoc` n-  BCons{}     -> b `BSnoc` n--blockJoinHead :: n C O -> Block n O x -> Block n C x-blockJoinHead f (BlockOC b l) = BlockCC f b l-blockJoinHead f b = BlockCO f BNil `cat` b--blockJoinTail :: Block n e O -> n O C -> Block n e C-blockJoinTail (BlockCO f b) t = BlockCC f b t-blockJoinTail b t = b `cat` BlockOC BNil t--blockJoin :: n C O -> Block n O O -> n O C -> Block n C C-blockJoin f b t = BlockCC f b t--blockAppend :: Block n e O -> Block n O x -> Block n e x-blockAppend = cat----- Taking apart--firstNode :: Block n C x -> n C O-firstNode (BlockCO n _)   = n-firstNode (BlockCC n _ _) = n--lastNode :: Block n x C -> n O C-lastNode (BlockOC   _ n) = n-lastNode (BlockCC _ _ n) = n--blockSplitHead :: Block n C x -> (n C O, Block n O x)-blockSplitHead (BlockCO n b)   = (n, b)-blockSplitHead (BlockCC n b t) = (n, BlockOC b t)--blockSplitTail :: Block n e C -> (Block n e O, n O C)-blockSplitTail (BlockOC b n)   = (b, n)-blockSplitTail (BlockCC f b t) = (BlockCO f b, t)---- | Split a closed block into its entry node, open middle block, and--- exit node.-blockSplit :: Block n C C -> (n C O, Block n O O, n O C)-blockSplit (BlockCC f b t) = (f, b, t)--blockToList :: Block n O O -> [n O O]-blockToList b = go b []-   where go :: Block n O O -> [n O O] -> [n O O]-         go BNil         r = r-         go (BMiddle n)  r = n : r-         go (BCat b1 b2) r = go b1 $! go b2 r-         go (BSnoc b1 n) r = go b1 (n:r)-         go (BCons n b1) r = n : go b1 r--blockFromList :: [n O O] -> Block n O O-blockFromList = foldr BCons BNil---- Modifying--replaceFirstNode :: Block n C x -> n C O -> Block n C x-replaceFirstNode (BlockCO _ b)   f = BlockCO f b-replaceFirstNode (BlockCC _ b n) f = BlockCC f b n--replaceLastNode :: Block n x C -> n O C -> Block n x C-replaceLastNode (BlockOC   b _) n = BlockOC b n-replaceLastNode (BlockCC l b _) n = BlockCC l b n---- -------------------------------------------------------------------------------- General concatenation--cat :: Block n e O -> Block n O x -> Block n e x-cat x y = case x of-  BNil -> y--  BlockCO l b1 -> case y of-                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n-                   BNil         -> x-                   BMiddle _    -> BlockCO l $! (b1 `cat` y)-                   BCat{}       -> BlockCO l $! (b1 `cat` y)-                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)-                   BCons{}      -> BlockCO l $! (b1 `cat` y)--  BMiddle n -> case y of-                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2-                   BNil          -> x-                   BMiddle{}     -> BCons n y-                   BCat{}        -> BCons n y-                   BSnoc{}       -> BCons n y-                   BCons{}       -> BCons n y--  BCat{} -> case y of-                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2-                   BNil          -> x-                   BMiddle n     -> BSnoc x n-                   BCat{}        -> BCat x y-                   BSnoc{}       -> BCat x y-                   BCons{}       -> BCat x y--  BSnoc{} -> case y of-                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2-                   BNil          -> x-                   BMiddle n     -> BSnoc x n-                   BCat{}        -> BCat x y-                   BSnoc{}       -> BCat x y-                   BCons{}       -> BCat x y---  BCons{} -> case y of-                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2-                   BNil          -> x-                   BMiddle n     -> BSnoc x n-                   BCat{}        -> BCat x y-                   BSnoc{}       -> BCat x y-                   BCons{}       -> BCat x y----- -------------------------------------------------------------------------------- Mapping---- | map a function over the nodes of a 'Block'-mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x-mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)-mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)-mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)-mapBlock _  BNil           = BNil-mapBlock f (BMiddle n)     = BMiddle (f n)-mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)-mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)-mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)---- | A strict 'mapBlock'-mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)-mapBlock' f = mapBlock3' (f, f, f)---- | map over a block, with different functions to apply to first nodes,--- middle nodes and last nodes respectively.  The map is strict.----mapBlock3' :: forall n n' e x .-             ( n C O -> n' C O-             , n O O -> n' O O,-               n O C -> n' O C)-          -> Block n e x -> Block n' e x-mapBlock3' (f, m, l) b = go b-  where go :: forall e x . Block n e x -> Block n' e x-        go (BlockOC b y)   = (BlockOC $! go b) $! l y-        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)-        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)-        go BNil            = BNil-        go (BMiddle n)     = BMiddle $! m n-        go (BCat x y)      = (BCat $! go x) $! (go y)-        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)-        go (BCons n x)     = (BCons $! m n) $! (go x)---- -------------------------------------------------------------------------------- Folding----- | Fold a function over every node in a block, forward or backward.--- The fold function must be polymorphic in the shape of the nodes.-foldBlockNodesF3 :: forall n a b c .-                   ( n C O       -> a -> b-                   , n O O       -> b -> b-                   , n O C       -> b -> c)-                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)-foldBlockNodesF  :: forall n a .-                    (forall e x . n e x       -> a -> a)-                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)-foldBlockNodesB3 :: forall n a b c .-                   ( n C O       -> b -> c-                   , n O O       -> b -> b-                   , n O C       -> a -> b)-                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)-foldBlockNodesB  :: forall n a .-                    (forall e x . n e x       -> a -> a)-                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)--foldBlockNodesF3 (ff, fm, fl) = block-  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b-        block (BlockCO f b  )   = ff f `cat` block b-        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l-        block (BlockOC   b l)   =            block b `cat` fl l-        block BNil              = id-        block (BMiddle node)    = fm node-        block (b1 `BCat`    b2) = block b1 `cat` block b2-        block (b1 `BSnoc` n)    = block b1 `cat` fm n-        block (n `BCons` b2)    = fm n `cat` block b2-        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c-        cat f f' = f' . f--foldBlockNodesF f = foldBlockNodesF3 (f, f, f)--foldBlockNodesB3 (ff, fm, fl) = block-  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b-        block (BlockCO f b  )   = ff f `cat` block b-        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l-        block (BlockOC   b l)   =            block b `cat` fl l-        block BNil              = id-        block (BMiddle node)    = fm node-        block (b1 `BCat`    b2) = block b1 `cat` block b2-        block (b1 `BSnoc` n)    = block b1 `cat` fm n-        block (n `BCons` b2)    = fm n `cat` block b2-        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c-        cat f f' = f . f'--foldBlockNodesB f = foldBlockNodesB3 (f, f, f)-
− compiler/cmm/Hoopl/Collections.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Hoopl.Collections-    ( IsSet(..)-    , setInsertList, setDeleteList, setUnions-    , IsMap(..)-    , mapInsertList, mapDeleteList, mapUnions-    , UniqueMap, UniqueSet-    ) where--import GhcPrelude--import qualified Data.IntMap.Strict as M-import qualified Data.IntSet as S--import Data.List (foldl1')--class IsSet set where-  type ElemOf set--  setNull :: set -> Bool-  setSize :: set -> Int-  setMember :: ElemOf set -> set -> Bool--  setEmpty :: set-  setSingleton :: ElemOf set -> set-  setInsert :: ElemOf set -> set -> set-  setDelete :: ElemOf set -> set -> set--  setUnion :: set -> set -> set-  setDifference :: set -> set -> set-  setIntersection :: set -> set -> set-  setIsSubsetOf :: set -> set -> Bool-  setFilter :: (ElemOf set -> Bool) -> set -> set--  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b-  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b--  setElems :: set -> [ElemOf set]-  setFromList :: [ElemOf set] -> set---- Helper functions for IsSet class-setInsertList :: IsSet set => [ElemOf set] -> set -> set-setInsertList keys set = foldl' (flip setInsert) set keys--setDeleteList :: IsSet set => [ElemOf set] -> set -> set-setDeleteList keys set = foldl' (flip setDelete) set keys--setUnions :: IsSet set => [set] -> set-setUnions [] = setEmpty-setUnions sets = foldl1' setUnion sets---class IsMap map where-  type KeyOf map--  mapNull :: map a -> Bool-  mapSize :: map a -> Int-  mapMember :: KeyOf map -> map a -> Bool-  mapLookup :: KeyOf map -> map a -> Maybe a-  mapFindWithDefault :: a -> KeyOf map -> map a -> a--  mapEmpty :: map a-  mapSingleton :: KeyOf map -> a -> map a-  mapInsert :: KeyOf map -> a -> map a -> map a-  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a-  mapDelete :: KeyOf map -> map a -> map a-  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a-  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a--  mapUnion :: map a -> map a -> map a-  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a-  mapDifference :: map a -> map a -> map a-  mapIntersection :: map a -> map a -> map a-  mapIsSubmapOf :: Eq a => map a -> map a -> Bool--  mapMap :: (a -> b) -> map a -> map b-  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b-  mapFoldl :: (b -> a -> b) -> b -> map a -> b-  mapFoldr :: (a -> b -> b) -> b -> map a -> b-  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b-  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m-  mapFilter :: (a -> Bool) -> map a -> map a-  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a---  mapElems :: map a -> [a]-  mapKeys :: map a -> [KeyOf map]-  mapToList :: map a -> [(KeyOf map, a)]-  mapFromList :: [(KeyOf map, a)] -> map a-  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a---- Helper functions for IsMap class-mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a-mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs--mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a-mapDeleteList keys map = foldl' (flip mapDelete) map keys--mapUnions :: IsMap map => [map a] -> map a-mapUnions [] = mapEmpty-mapUnions maps = foldl1' mapUnion maps---------------------------------------------------------------------------------- Basic instances--------------------------------------------------------------------------------newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)--instance IsSet UniqueSet where-  type ElemOf UniqueSet = Int--  setNull (US s) = S.null s-  setSize (US s) = S.size s-  setMember k (US s) = S.member k s--  setEmpty = US S.empty-  setSingleton k = US (S.singleton k)-  setInsert k (US s) = US (S.insert k s)-  setDelete k (US s) = US (S.delete k s)--  setUnion (US x) (US y) = US (S.union x y)-  setDifference (US x) (US y) = US (S.difference x y)-  setIntersection (US x) (US y) = US (S.intersection x y)-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y-  setFilter f (US s) = US (S.filter f s)--  setFoldl k z (US s) = S.foldl' k z s-  setFoldr k z (US s) = S.foldr k z s--  setElems (US s) = S.elems s-  setFromList ks = US (S.fromList ks)--newtype UniqueMap v = UM (M.IntMap v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)--instance IsMap UniqueMap where-  type KeyOf UniqueMap = Int--  mapNull (UM m) = M.null m-  mapSize (UM m) = M.size m-  mapMember k (UM m) = M.member k m-  mapLookup k (UM m) = M.lookup k m-  mapFindWithDefault def k (UM m) = M.findWithDefault def k m--  mapEmpty = UM M.empty-  mapSingleton k v = UM (M.singleton k v)-  mapInsert k v (UM m) = UM (M.insert k v m)-  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)-  mapDelete k (UM m) = UM (M.delete k m)-  mapAlter f k (UM m) = UM (M.alter f k m)-  mapAdjust f k (UM m) = UM (M.adjust f k m)--  mapUnion (UM x) (UM y) = UM (M.union x y)-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)-  mapDifference (UM x) (UM y) = UM (M.difference x y)-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y--  mapMap f (UM m) = UM (M.map f m)-  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)-  mapFoldl k z (UM m) = M.foldl' k z m-  mapFoldr k z (UM m) = M.foldr k z m-  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m-  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m-  mapFilter f (UM m) = UM (M.filter f m)-  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)--  mapElems (UM m) = M.elems m-  mapKeys (UM m) = M.keys m-  mapToList (UM m) = M.toList m-  mapFromList assocs = UM (M.fromList assocs)-  mapFromListWith f assocs = UM (M.fromListWith f assocs)
− compiler/cmm/Hoopl/Dataflow.hs 
@@ -1,441 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}------- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,--- and Norman Ramsey------ Modifications copyright (c) The University of Glasgow 2012------ This module is a specialised and optimised version of--- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is--- specialised to the UniqSM monad.-----module Hoopl.Dataflow-  ( C, O, Block-  , lastNode, entryLabel-  , foldNodesBwdOO-  , foldRewriteNodesBwdOO-  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)-  , TransferFun, RewriteFun-  , Fact, FactBase-  , getFact, mkFactBase-  , analyzeCmmFwd, analyzeCmmBwd-  , rewriteCmmBwd-  , changedIf-  , joinOutFacts-  , joinFacts-  )-where--import GhcPrelude--import Cmm-import UniqSupply--import Data.Array-import Data.Maybe-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet--import Hoopl.Block-import Hoopl.Graph-import Hoopl.Collections-import Hoopl.Label--type family   Fact (x :: Extensibility) f :: *-type instance Fact C f = FactBase f-type instance Fact O f = f--newtype OldFact a = OldFact a--newtype NewFact a = NewFact a---- | The result of joining OldFact and NewFact.-data JoinedFact a-    = Changed !a     -- ^ Result is different than OldFact.-    | NotChanged !a  -- ^ Result is the same as OldFact.--getJoined :: JoinedFact a -> a-getJoined (Changed a) = a-getJoined (NotChanged a) = a--changedIf :: Bool -> a -> JoinedFact a-changedIf True = Changed-changedIf False = NotChanged--type JoinFun a = OldFact a -> NewFact a -> JoinedFact a--data DataflowLattice a = DataflowLattice-    { fact_bot :: a-    , fact_join :: JoinFun a-    }--data Direction = Fwd | Bwd--type TransferFun f = CmmBlock -> FactBase f -> FactBase f---- | Function for rewrtiting and analysis combined. To be used with--- @rewriteCmm@.------ Currently set to work with @UniqSM@ monad, but we could probably abstract--- that away (if we do that, we might want to specialize the fixpoint algorithms--- to the particular monads through SPECIALIZE).-type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)--analyzeCmmBwd, analyzeCmmFwd-    :: DataflowLattice f-    -> TransferFun f-    -> CmmGraph-    -> FactBase f-    -> FactBase f-analyzeCmmBwd = analyzeCmm Bwd-analyzeCmmFwd = analyzeCmm Fwd--analyzeCmm-    :: Direction-    -> DataflowLattice f-    -> TransferFun f-    -> CmmGraph-    -> FactBase f-    -> FactBase f-analyzeCmm dir lattice transfer cmmGraph initFact =-    {-# SCC analyzeCmm #-}-    let entry = g_entry cmmGraph-        hooplGraph = g_graph cmmGraph-        blockMap =-            case hooplGraph of-                GMany NothingO bm NothingO -> bm-    in fixpointAnalysis dir lattice transfer entry blockMap initFact---- Fixpoint algorithm.-fixpointAnalysis-    :: forall f.-       Direction-    -> DataflowLattice f-    -> TransferFun f-    -> Label-    -> LabelMap CmmBlock-    -> FactBase f-    -> FactBase f-fixpointAnalysis direction lattice do_block entry blockmap = loop start-  where-    -- Sorting the blocks helps to minimize the number of times we need to-    -- process blocks. For instance, for forward analysis we want to look at-    -- blocks in reverse postorder. Also, see comments for sortBlocks.-    blocks     = sortBlocks direction entry blockmap-    num_blocks = length blocks-    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks-    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList-      [0 .. num_blocks - 1]-    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks-    join       = fact_join lattice--    loop-        :: IntHeap     -- ^ Worklist, i.e., blocks to process-        -> FactBase f  -- ^ Current result (increases monotonically)-        -> FactBase f-    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =-        let block = block_arr ! index-            out_facts = {-# SCC "do_block" #-} do_block block fbase1-            -- For each of the outgoing edges, we join it with the current-            -- information in fbase1 and (if something changed) we update it-            -- and add the affected blocks to the worklist.-            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}-                mapFoldlWithKey-                    (updateFact join dep_blocks) (todo1, fbase1) out_facts-        in loop todo2 fbase2-    loop _ !fbase1 = fbase1--rewriteCmmBwd-    :: DataflowLattice f-    -> RewriteFun f-    -> CmmGraph-    -> FactBase f-    -> UniqSM (CmmGraph, FactBase f)-rewriteCmmBwd = rewriteCmm Bwd--rewriteCmm-    :: Direction-    -> DataflowLattice f-    -> RewriteFun f-    -> CmmGraph-    -> FactBase f-    -> UniqSM (CmmGraph, FactBase f)-rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do-    let entry = g_entry cmmGraph-        hooplGraph = g_graph cmmGraph-        blockMap1 =-            case hooplGraph of-                GMany NothingO bm NothingO -> bm-    (blockMap2, facts) <--        fixpointRewrite dir lattice rwFun entry blockMap1 initFact-    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)--fixpointRewrite-    :: forall f.-       Direction-    -> DataflowLattice f-    -> RewriteFun f-    -> Label-    -> LabelMap CmmBlock-    -> FactBase f-    -> UniqSM (LabelMap CmmBlock, FactBase f)-fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap-  where-    -- Sorting the blocks helps to minimize the number of times we need to-    -- process blocks. For instance, for forward analysis we want to look at-    -- blocks in reverse postorder. Also, see comments for sortBlocks.-    blocks     = sortBlocks dir entry blockmap-    num_blocks = length blocks-    block_arr  = {-# SCC "block_arr_rewrite" #-}-                 listArray (0, num_blocks - 1) blocks-    start      = {-# SCC "start_rewrite" #-}-                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]-    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks-    join       = fact_join lattice--    loop-        :: IntHeap            -- ^ Worklist, i.e., blocks to process-        -> LabelMap CmmBlock  -- ^ Rewritten blocks.-        -> FactBase f         -- ^ Current facts.-        -> UniqSM (LabelMap CmmBlock, FactBase f)-    loop todo !blocks1 !fbase1-      | Just (index, todo1) <- IntSet.minView todo = do-        -- Note that we use the *original* block here. This is important.-        -- We're optimistically rewriting blocks even before reaching the fixed-        -- point, which means that the rewrite might be incorrect. So if the-        -- facts change, we need to rewrite the original block again (taking-        -- into account the new facts).-        let block = block_arr ! index-        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}-            do_block block fbase1-        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1-            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}-                mapFoldlWithKey-                    (updateFact join dep_blocks) (todo1, fbase1) out_facts-        loop todo2 blocks2 fbase2-    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)---{--Note [Unreachable blocks]-~~~~~~~~~~~~~~~~~~~~~~~~~-A block that is not in the domain of tfb_fbase is "currently unreachable".-A currently-unreachable block is not even analyzed.  Reason: consider-constant prop and this graph, with entry point L1:-  L1: x:=3; goto L4-  L2: x:=4; goto L4-  L4: if x>3 goto L2 else goto L5-Here L2 is actually unreachable, but if we process it with bottom input fact,-we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.--* If a currently-unreachable block is not analyzed, then its rewritten-  graph will not be accumulated in tfb_rg.  And that is good:-  unreachable blocks simply do not appear in the output.--* Note that clients must be careful to provide a fact (even if bottom)-  for each entry point. Otherwise useful blocks may be garbage collected.--* Note that updateFact must set the change-flag if a label goes from-  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the-  real fact lattice is-       UNR-       bottom-       the points above bottom--* Even if the fact is going from UNR to bottom, we still call the-  client's fact_join function because it might give the client-  some useful debugging information.--* All of this only applies for *forward* ixpoints.  For the backward-  case we must treat every block as reachable; it might finish with a-  'return', and therefore have no successors, for example.--}-----------------------------------------------------------------------------------  Pieces that are shared by fixpoint and fixpoint_anal---------------------------------------------------------------------------------- | Sort the blocks into the right order for analysis. This means reverse--- postorder for a forward analysis. For the backward one, we simply reverse--- that (see Note [Backward vs forward analysis]).-sortBlocks-    :: NonLocal n-    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]-sortBlocks direction entry blockmap =-    case direction of-        Fwd -> fwd-        Bwd -> reverse fwd-  where-    fwd = revPostorderFrom blockmap entry---- Note [Backward vs forward analysis]------ The forward and backward cases are not dual.  In the forward case, the entry--- points are known, and one simply traverses the body blocks from those points.--- In the backward case, something is known about the exit points, but a--- backward analysis must also include reachable blocks that don't reach the--- exit, as in a procedure that loops forever and has side effects.)--- For instance, let E be the entry and X the exit blocks (arrows indicate--- control flow)---   E -> X---   E -> B---   B -> C---   C -> B--- We do need to include B and C even though they're unreachable in the--- *reverse* graph (that we could use for backward analysis):---   E <- X---   E <- B---   B <- C---   C <- B--- So when sorting the blocks for the backward analysis, we simply take the--- reverse of what is used for the forward one.----- | Construct a mapping from a @Label@ to the block indexes that should be--- re-analyzed if the facts at that @Label@ change.------ Note that we're considering here the entry point of the block, so if the--- facts change at the entry:--- * for a backward analysis we need to re-analyze all the predecessors, but--- * for a forward analysis, we only need to re-analyze the current block---   (and that will in turn propagate facts into its successors).-mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet-mkDepBlocks Fwd blocks = go blocks 0 mapEmpty-  where-    go []     !_ !dep_map = dep_map-    go (b:bs) !n !dep_map =-        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map-mkDepBlocks Bwd blocks = go blocks 0 mapEmpty-  where-    go []     !_ !dep_map = dep_map-    go (b:bs) !n !dep_map =-        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m-        in go bs (n + 1) $ foldl' insert dep_map (successors b)---- | After some new facts have been generated by analysing a block, we--- fold this function over them to generate (a) a list of block--- indices to (re-)analyse, and (b) the new FactBase.-updateFact-    :: JoinFun f-    -> LabelMap IntSet-    -> (IntHeap, FactBase f)-    -> Label-    -> f -- out fact-    -> (IntHeap, FactBase f)-updateFact fact_join dep_blocks (todo, fbase) lbl new_fact-  = case lookupFact lbl fbase of-      Nothing ->-          -- Note [No old fact]-          let !z = mapInsert lbl new_fact fbase in (changed, z)-      Just old_fact ->-          case fact_join (OldFact old_fact) (NewFact new_fact) of-              (NotChanged _) -> (todo, fbase)-              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)-  where-    changed = todo `IntSet.union`-              mapFindWithDefault IntSet.empty lbl dep_blocks--{--Note [No old fact]--We know that the new_fact is >= _|_, so we don't need to join.  However,-if the new fact is also _|_, and we have already analysed its block,-we don't need to record a change.  So there's a tradeoff here.  It turns-out that always recording a change is faster.--}---------------------------------------------------------------------       Utilities--------------------------------------------------------------------- Fact lookup: the fact `orelse` bottom-getFact  :: DataflowLattice f -> Label -> FactBase f -> f-getFact lat l fb = case lookupFact l fb of Just  f -> f-                                           Nothing -> fact_bot lat---- | Returns the result of joining the facts from all the successors of the--- provided node or block.-joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f-joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts-  where-    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)-    facts =-        [ fromJust fact-        | s <- successors nonLocal-        , let fact = lookupFact s fact_base-        , isJust fact-        ]--joinFacts :: DataflowLattice f -> [f] -> f-joinFacts lattice facts  = foldl' join (fact_bot lattice) facts-  where-    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)---- | Returns the joined facts for each label.-mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f-mkFactBase lattice = foldl' add mapEmpty-  where-    join = fact_join lattice--    add result (l, f1) =-        let !newFact =-                case mapLookup l result of-                    Nothing -> f1-                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)-        in mapInsert l newFact result---- | Folds backward over all nodes of an open-open block.--- Strict in the accumulator.-foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f-foldNodesBwdOO funOO = go-  where-    go (BCat b1 b2) f = go b1 $! go b2 f-    go (BSnoc h n) f = go h $! funOO n f-    go (BCons n t) f = funOO n $! go t f-    go (BMiddle n) f = funOO n f-    go BNil f = f-{-# INLINABLE foldNodesBwdOO #-}---- | Folds backward over all the nodes of an open-open block and allows--- rewriting them. The accumulator is both the block of nodes and @f@ (usually--- dataflow facts).--- Strict in both accumulated parts.-foldRewriteNodesBwdOO-    :: forall f.-       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))-    -> Block CmmNode O O-    -> f-    -> UniqSM (Block CmmNode O O, f)-foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts-  where-    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1-    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1-    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1-    go (BMiddle node) !fact1 = rewriteOO node fact1-    go BNil !fact = return (BNil, fact)--    comp rew1 rew2 = \f1 -> do-        (b, f2) <- rew2 f1-        (a, !f3) <- rew1 f2-        let !c = joinBlocksOO a b-        return (c, f3)-    {-# INLINE comp #-}-{-# INLINABLE foldRewriteNodesBwdOO #-}--joinBlocksOO :: Block n O O -> Block n O O -> Block n O O-joinBlocksOO BNil b = b-joinBlocksOO b BNil = b-joinBlocksOO (BMiddle n) b = blockCons n b-joinBlocksOO b (BMiddle n) = blockSnoc b n-joinBlocksOO b1 b2 = BCat b1 b2--type IntHeap = IntSet
− compiler/cmm/Hoopl/Graph.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-module Hoopl.Graph-    ( Body-    , Graph-    , Graph'(..)-    , NonLocal(..)-    , addBlock-    , bodyList-    , emptyBody-    , labelsDefined-    , mapGraph-    , mapGraphBlocks-    , revPostorderFrom-    ) where---import GhcPrelude-import Util--import Hoopl.Label-import Hoopl.Block-import Hoopl.Collections---- | A (possibly empty) collection of closed/closed blocks-type Body n = LabelMap (Block n C C)---- | @Body@ abstracted over @block@-type Body' block (n :: Extensibility -> Extensibility -> *) = LabelMap (block n C C)------------------------------------ | Gives access to the anchor points for--- nonlocal edges as well as the edges themselves-class NonLocal thing where-  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block-  successors :: thing e C -> [Label] -- ^ Gives control-flow successors--instance NonLocal n => NonLocal (Block n) where-  entryLabel (BlockCO f _)   = entryLabel f-  entryLabel (BlockCC f _ _) = entryLabel f--  successors (BlockOC   _ n) = successors n-  successors (BlockCC _ _ n) = successors n---emptyBody :: Body' block n-emptyBody = mapEmpty--bodyList :: Body' block n -> [(Label,block n C C)]-bodyList body = mapToList body--addBlock-    :: (NonLocal block, HasDebugCallStack)-    => block C C -> LabelMap (block C C) -> LabelMap (block C C)-addBlock block body = mapAlter add lbl body-  where-    lbl = entryLabel block-    add Nothing = Just block-    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"----- ------------------------------------------------------------------------------ Graph---- | A control-flow graph, which may take any of four shapes (O/O,--- O/C, C/O, C/C).  A graph open at the entry has a single,--- distinguished, anonymous entry point; if a graph is closed at the--- entry, its entry point(s) are supplied by a context.-type Graph = Graph' Block---- | @Graph'@ is abstracted over the block type, so that we can build--- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow--- needs this).-data Graph' block (n :: Extensibility -> Extensibility -> *) e x where-  GNil  :: Graph' block n O O-  GUnit :: block n O O -> Graph' block n O O-  GMany :: MaybeO e (block n O C)-        -> Body' block n-        -> MaybeO x (block n C O)-        -> Graph' block n e x----- -------------------------------------------------------------------------------- Mapping over graphs---- | Maps over all nodes in a graph.-mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x-mapGraph f = mapGraphBlocks (mapBlock f)---- | Function 'mapGraphBlocks' enables a change of representation of blocks,--- nodes, or both.  It lifts a polymorphic block transform into a polymorphic--- graph transform.  When the block representation stabilizes, a similar--- function should be provided for blocks.-mapGraphBlocks :: forall block n block' n' e x .-                  (forall e x . block n e x -> block' n' e x)-               -> (Graph' block n e x -> Graph' block' n' e x)--mapGraphBlocks f = map-  where map :: Graph' block n e x -> Graph' block' n' e x-        map GNil = GNil-        map (GUnit b) = GUnit (f b)-        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)---- -------------------------------------------------------------------------------- Extracting Labels from graphs--labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x-              -> LabelSet-labelsDefined GNil      = setEmpty-labelsDefined (GUnit{}) = setEmpty-labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body-  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet-        addEntry labels label _ = setInsert label labels-        exitLabel :: MaybeO x (block n C O) -> LabelSet-        exitLabel NothingO  = setEmpty-        exitLabel (JustO b) = setSingleton (entryLabel b)----------------------------------------------------------------------- | Returns a list of blocks reachable from the provided Labels in the reverse--- postorder.------ This is the most important traversal over this data structure.  It drops--- unreachable code and puts blocks in an order that is good for solving forward--- dataflow problems quickly.  The reverse order is good for solving backward--- dataflow problems quickly.  The forward order is also reasonably good for--- emitting instructions, except that it will not usually exploit Forrest--- Baskett's trick of eliminating the unconditional branch from a loop.  For--- that you would need a more serious analysis, probably based on dominators, to--- identify loop headers.------ For forward analyses we want reverse postorder visitation, consider:--- @---      A -> [B,C]---      B -> D---      C -> D--- @--- Postorder: [D, C, B, A] (or [D, B, C, A])--- Reverse postorder: [A, B, C, D] (or [A, C, B, D])--- This matters for, e.g., forward analysis, because we want to analyze *both*--- B and C before we analyze D.-revPostorderFrom-  :: forall block.  (NonLocal block)-  => LabelMap (block C C) -> Label -> [block C C]-revPostorderFrom graph start = go start_worklist setEmpty []-  where-    start_worklist = lookup_for_descend start Nil--    -- To compute the postorder we need to "visit" a block (mark as done)-    -- *after* visiting all its successors. So we need to know whether we-    -- already processed all successors of each block (and @NonLocal@ allows-    -- arbitrary many successors). So we use an explicit stack with an extra bit-    -- of information:-    -- * @ConsTodo@ means to explore the block if it wasn't visited before-    -- * @ConsMark@ means that all successors were already done and we can add-    --   the block to the result.-    ---    -- NOTE: We add blocks to the result list in postorder, but we *prepend*-    -- them (i.e., we use @(:)@), which means that the final list is in reverse-    -- postorder.-    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]-    go Nil                      !_           !result = result-    go (ConsMark block rest)    !wip_or_done !result =-        go rest wip_or_done (block : result)-    go (ConsTodo block rest)    !wip_or_done !result-        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result-        | otherwise =-            let new_worklist =-                    foldr lookup_for_descend-                          (ConsMark block rest)-                          (successors block)-            in go new_worklist (setInsert (entryLabel block) wip_or_done) result--    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)-    lookup_for_descend label wl-      | Just b <- mapLookup label graph = ConsTodo b wl-      | otherwise =-           error $ "Label that doesn't have a block?! " ++ show label--data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
− compiler/cmm/Hoopl/Label.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Hoopl.Label-    ( Label-    , LabelMap-    , LabelSet-    , FactBase-    , lookupFact-    , mkHooplLabel-    ) where--import GhcPrelude--import Outputable---- TODO: This should really just use GHC's Unique and Uniq{Set,FM}-import Hoopl.Collections--import Unique (Uniquable(..))-import TrieMap-----------------------------------------------------------------------------------              Label--------------------------------------------------------------------------------newtype Label = Label { lblToUnique :: Int }-  deriving (Eq, Ord)--mkHooplLabel :: Int -> Label-mkHooplLabel = Label--instance Show Label where-  show (Label n) = "L" ++ show n--instance Uniquable Label where-  getUnique label = getUnique (lblToUnique label)--instance Outputable Label where-  ppr label = ppr (getUnique label)---------------------------------------------------------------------------------- LabelSet--newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)--instance IsSet LabelSet where-  type ElemOf LabelSet = Label--  setNull (LS s) = setNull s-  setSize (LS s) = setSize s-  setMember (Label k) (LS s) = setMember k s--  setEmpty = LS setEmpty-  setSingleton (Label k) = LS (setSingleton k)-  setInsert (Label k) (LS s) = LS (setInsert k s)-  setDelete (Label k) (LS s) = LS (setDelete k s)--  setUnion (LS x) (LS y) = LS (setUnion x y)-  setDifference (LS x) (LS y) = LS (setDifference x y)-  setIntersection (LS x) (LS y) = LS (setIntersection x y)-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y-  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)-  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s-  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s--  setElems (LS s) = map mkHooplLabel (setElems s)-  setFromList ks = LS (setFromList (map lblToUnique ks))---------------------------------------------------------------------------------- LabelMap--newtype LabelMap v = LM (UniqueMap v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)--instance IsMap LabelMap where-  type KeyOf LabelMap = Label--  mapNull (LM m) = mapNull m-  mapSize (LM m) = mapSize m-  mapMember (Label k) (LM m) = mapMember k m-  mapLookup (Label k) (LM m) = mapLookup k m-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m--  mapEmpty = LM mapEmpty-  mapSingleton (Label k) v = LM (mapSingleton k v)-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)-  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)-  mapDelete (Label k) (LM m) = LM (mapDelete k m)-  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)-  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)--  mapUnion (LM x) (LM y) = LM (mapUnion x y)-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)-  mapDifference (LM x) (LM y) = LM (mapDifference x y)-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y--  mapMap f (LM m) = LM (mapMap f m)-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)-  mapFoldl k z (LM m) = mapFoldl k z m-  mapFoldr k z (LM m) = mapFoldr k z m-  mapFoldlWithKey k z (LM m) =-      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m-  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m-  mapFilter f (LM m) = LM (mapFilter f m)-  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)--  mapElems (LM m) = mapElems m-  mapKeys (LM m) = map mkHooplLabel (mapKeys m)-  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])-  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])---------------------------------------------------------------------------------- Instances--instance Outputable LabelSet where-  ppr = ppr . setElems--instance Outputable a => Outputable (LabelMap a) where-  ppr = ppr . mapToList--instance TrieMap LabelMap where-  type Key LabelMap = Label-  emptyTM = mapEmpty-  lookupTM k m = mapLookup k m-  alterTM k f m = mapAlter f k m-  foldTM k m z = mapFoldr k z m-  mapTM f m = mapMap f m---------------------------------------------------------------------------------- FactBase--type FactBase f = LabelMap f--lookupFact :: Label -> FactBase f -> Maybe f-lookupFact = mapLookup
− compiler/cmm/MkGraph.hs 
@@ -1,484 +0,0 @@-{-# LANGUAGE BangPatterns, GADTs #-}--module MkGraph-  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)-  , (<*>), catAGraphs-  , mkLabel, mkMiddle, mkLast, outOfLine-  , lgraphOfAGraph, labelAGraph--  , stackStubExpr-  , mkNop, mkAssign, mkStore-  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo-  , mkJumpReturnsTo-  , mkJump, mkJumpExtra-  , mkRawJump-  , mkCbranch, mkSwitch-  , mkReturn, mkComment, mkCallEntry, mkBranch-  , mkUnwind-  , copyInOflow, copyOutOflow-  , noExtraStack-  , toCall, Transfer(..)-  )-where--import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)--import BlockId-import Cmm-import CmmCallConv-import CmmSwitch (SwitchTargets)--import Hoopl.Block-import Hoopl.Graph-import Hoopl.Label-import DynFlags-import FastString-import ForeignCall-import OrdList-import SMRep (ByteOff)-import UniqSupply-import Util-import Panic----------------------------------------------------------------------------------- Building Graphs----- | CmmAGraph is a chunk of code consisting of:------   * ordinary statements (assignments, stores etc.)---   * jumps---   * labels---   * out-of-line labelled blocks------ The semantics is that control falls through labels and out-of-line--- blocks.  Everything after a jump up to the next label is by--- definition unreachable code, and will be discarded.------ Two CmmAGraphs can be stuck together with <*>, with the meaning that--- control flows from the first to the second.------ A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)--- by providing a label for the entry point and a tick scope; see--- 'labelAGraph'.-type CmmAGraph = OrdList CgStmt--- | Unlabeled graph with tick scope-type CmmAGraphScoped = (CmmAGraph, CmmTickScope)--data CgStmt-  = CgLabel BlockId CmmTickScope-  | CgStmt  (CmmNode O O)-  | CgLast  (CmmNode O C)-  | CgFork  BlockId CmmAGraph CmmTickScope--flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph-flattenCmmAGraph id (stmts_t, tscope) =-    CmmGraph { g_entry = id,-               g_graph = GMany NothingO body NothingO }-  where-  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []--  ---  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.-  ---  -- NB. avoid the quadratic-append trap by passing in the tail of the-  -- list.  This is important for Very Long Functions (e.g. in T783).-  ---  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]-          -> [Block CmmNode C C]-  flatten id g tscope blocks-      = flatten1 (fromOL g) block' blocks-      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock-  ---  -- flatten0: we are outside a block at this point: any code before-  -- the first label is unreachable, so just drop it.-  ---  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]-  flatten0 [] blocks = blocks--  flatten0 (CgLabel id tscope : stmts) blocks-    = flatten1 stmts block blocks-    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock--  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks-    = flatten fork_id stmts_t tscope $ flatten0 rest blocks--  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks-  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks--  ---  -- flatten1: we have a partial block, collect statements until the-  -- next last node to make a block, then call flatten0 to get the rest-  -- of the blocks-  ---  flatten1 :: [CgStmt] -> Block CmmNode C O-           -> [Block CmmNode C C] -> [Block CmmNode C C]--  -- The current block falls through to the end of a function or fork:-  -- this code should not be reachable, but it may be referenced by-  -- other code that is not reachable.  We'll remove it later with-  -- dead-code analysis, but for now we have to keep the graph-  -- well-formed, so we terminate the block with a branch to the-  -- beginning of the current block.-  flatten1 [] block blocks-    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks--  flatten1 (CgLast stmt : stmts) block blocks-    = block' : flatten0 stmts blocks-    where !block' = blockJoinTail block stmt--  flatten1 (CgStmt stmt : stmts) block blocks-    = flatten1 stmts block' blocks-    where !block' = blockSnoc block stmt--  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks-    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks--  -- a label here means that we should start a new block, and the-  -- current block should fall through to the new block.-  flatten1 (CgLabel id tscp : stmts) block blocks-    = blockJoinTail block (CmmBranch id) :-      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks-------------- AGraph manipulation--(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph-(<*>)           = appOL--catAGraphs     :: [CmmAGraph] -> CmmAGraph-catAGraphs      = concatOL---- | creates a sequence "goto id; id:" as an AGraph-mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph-mkLabel bid scp = unitOL (CgLabel bid scp)---- | creates an open AGraph from a given node-mkMiddle        :: CmmNode O O -> CmmAGraph-mkMiddle middle = unitOL (CgStmt middle)---- | creates a closed AGraph from a given node-mkLast         :: CmmNode O C -> CmmAGraph-mkLast last     = unitOL (CgLast last)---- | A labelled code block; should end in a last node-outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph-outOfLine l (c,s) = unitOL (CgFork l c s)---- | allocate a fresh label for the entry point-lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph-lgraphOfAGraph g = do-  u <- getUniqueM-  return (labelAGraph (mkBlockId u) g)---- | use the given BlockId as the label of the entry point-labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph-labelAGraph lbl ag = flattenCmmAGraph lbl ag------------ No-ops-mkNop        :: CmmAGraph-mkNop         = nilOL--mkComment    :: FastString -> CmmAGraph-mkComment fs-  -- SDM: generating all those comments takes time, this saved about 4% for me-  | debugIsOn = mkMiddle $ CmmComment fs-  | otherwise = nilOL------------ Assignment and store-mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph-mkAssign l (CmmReg r) | l == r  = mkNop-mkAssign l r  = mkMiddle $ CmmAssign l r--mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph-mkStore  l r  = mkMiddle $ CmmStore  l r------------ Control transfer-mkJump          :: DynFlags -> Convention -> CmmExpr-                -> [CmmExpr]-                -> UpdFrameOffset-                -> CmmAGraph-mkJump dflags conv e actuals updfr_off =-  lastWithArgs dflags Jump Old conv actuals updfr_off $-    toCall e Nothing updfr_off 0---- | A jump where the caller says what the live GlobalRegs are.  Used--- for low-level hand-written Cmm.-mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]-                -> CmmAGraph-mkRawJump dflags e updfr_off vols =-  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $-    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols---mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]-                -> UpdFrameOffset -> [CmmExpr]-                -> CmmAGraph-mkJumpExtra dflags conv e actuals updfr_off extra_stack =-  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $-    toCall e Nothing updfr_off 0--mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph-mkCbranch pred ifso ifnot likely =-  mkLast (CmmCondBranch pred ifso ifnot likely)--mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph-mkSwitch e tbl   = mkLast $ CmmSwitch e tbl--mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset-                -> CmmAGraph-mkReturn dflags e actuals updfr_off =-  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $-    toCall e Nothing updfr_off 0--mkBranch        :: BlockId -> CmmAGraph-mkBranch bid     = mkLast (CmmBranch bid)--mkFinalCall   :: DynFlags-              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset-              -> CmmAGraph-mkFinalCall dflags f _ actuals updfr_off =-  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $-    toCall f Nothing updfr_off 0--mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]-                -> BlockId-                -> ByteOff-                -> UpdFrameOffset-                -> [CmmExpr]-                -> CmmAGraph-mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do-  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals-     updfr_off extra_stack $-       toCall f (Just ret_lbl) updfr_off ret_off---- Like mkCallReturnsTo, but does not push the return address (it is assumed to be--- already on the stack).-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]-                -> BlockId-                -> ByteOff-                -> UpdFrameOffset-                -> CmmAGraph-mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do-  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $-       toCall f (Just ret_lbl) updfr_off ret_off--mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph-mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as---- | Construct a 'CmmUnwind' node for the given register and unwinding--- expression.-mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph-mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]----------------------------------------------------------------------------------- Why are we inserting extra blocks that simply branch to the successors?--- Because in addition to the branch instruction, @mkBranch@ will insert--- a necessary adjustment to the stack pointer.----- For debugging purposes, we can stub out dead stack slots:-stackStubExpr :: Width -> CmmExpr-stackStubExpr w = CmmLit (CmmInt 0 w)---- When we copy in parameters, we usually want to put overflow--- parameters on the stack, but sometimes we want to pass the--- variables in their spill slots.  Therefore, for copying arguments--- and results, we provide different functions to pass the arguments--- in an overflow area and to pass them in spill slots.-copyInOflow  :: DynFlags -> Convention -> Area-             -> [CmmFormal]-             -> [CmmFormal]-             -> (Int, [GlobalReg], CmmAGraph)--copyInOflow dflags conv area formals extra_stk-  = (offset, gregs, catAGraphs $ map mkMiddle nodes)-  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk---- Return the number of bytes used for copying arguments, as well as the--- instructions to copy the arguments.-copyIn :: DynFlags -> Convention -> Area-       -> [CmmFormal]-       -> [CmmFormal]-       -> (ByteOff, [GlobalReg], [CmmNode O O])-copyIn dflags conv area formals extra_stk-  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))-  where-    -- See Note [Width of parameters]-    ci (reg, RegisterParam r@(VanillaReg {})) =-        let local = CmmLocal reg-            global = CmmReg (CmmGlobal r)-            width = cmmRegWidth dflags local-            expr-                | width == wordWidth dflags = global-                | width < wordWidth dflags =-                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]-                | otherwise = panic "Parameter width greater than word width"--        in CmmAssign local expr--    -- Non VanillaRegs-    ci (reg, RegisterParam r) =-        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))--    ci (reg, StackParam off)-      | isBitsType $ localRegType reg-      , typeWidth (localRegType reg) < wordWidth dflags =-        let-          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))-          local = CmmLocal reg-          width = cmmRegWidth dflags local-          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]-        in CmmAssign local expr--      | otherwise =-         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)-         where ty = localRegType reg--    init_offset = widthInBytes (wordWidth dflags) -- infotable--    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk--    (stk_size, args) = assignArgumentsPos dflags stk_off conv-                                          localRegType formals---- Factoring out the common parts of the copyout functions yielded something--- more complicated:--data Transfer = Call | JumpRet | Jump | Ret deriving Eq--copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]-             -> UpdFrameOffset-             -> [CmmExpr] -- extra stack args-             -> (Int, [GlobalReg], CmmAGraph)---- Generate code to move the actual parameters into the locations--- required by the calling convention.  This includes a store for the--- return address.------ The argument layout function ignores the pointer to the info table,--- so we slot that in here. When copying-out to a young area, we set--- the info table for return and adjust the offsets of the other--- parameters.  If this is a call instruction, we adjust the offsets--- of the other parameters.-copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff-  = (stk_size, regs, graph)-  where-    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)--    -- See Note [Width of parameters]-    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =-        let width = cmmExprWidth dflags v-            value-                | width == wordWidth dflags = v-                | width < wordWidth dflags =-                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]-                | otherwise = panic "Parameter width greater than word width"--        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)--    -- Non VanillaRegs-    co (v, RegisterParam r) (rs, ms) =-        (r:rs, mkAssign (CmmGlobal r) v <*> ms)--    -- See Note [Width of parameters]-    co (v, StackParam off)  (rs, ms)-      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)--    width v = cmmExprWidth dflags v-    value v-      | isBitsType $ cmmExprType dflags v-      , width v < wordWidth dflags =-        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]-      | otherwise = v--    (setRA, init_offset) =-      case area of-            Young id ->  -- Generate a store instruction for-                         -- the return address if making a call-                  case transfer of-                     Call ->-                       ([(CmmLit (CmmBlock id), StackParam init_offset)],-                       widthInBytes (wordWidth dflags))-                     JumpRet ->-                       ([],-                       widthInBytes (wordWidth dflags))-                     _other ->-                       ([], 0)-            Old -> ([], updfr_off)--    (extra_stack_off, stack_params) =-       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff--    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it-    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv-                                          (cmmExprType dflags) actuals----- Note [Width of parameters]------ Consider passing a small (< word width) primitive like Int8# to a function.--- It's actually non-trivial to do this without extending/narrowing:--- * Global registers are considered to have native word width (i.e., 64-bits on---   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a---   global register.--- * Same problem exists with LLVM IR.--- * Lowering gets harder since on x86-32 not every register exposes its lower---   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding---   8-bit register for %edi). So we would either need to extend/narrow anyway,---   or complicate the calling convention.--- * Passing a small integer in a stack slot, which has native word width,---   requires extending to word width when writing to the stack and narrowing---   when reading off the stack (see #16258).--- So instead, we always extend every parameter smaller than native word width--- in copyOutOflow and then truncate it back to the expected width in copyIn.--- Note that we do this in cmm using MO_XX_Conv to avoid requiring--- zero-/sign-extending - it's up to a backend to handle this in a most--- efficient way (e.g., a simple register move or a smaller size store).--- This convention (of ignoring the upper bits) is different from some C ABIs,--- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.------ There was some discussion about this on this PR:--- https://github.com/ghc-proposals/ghc-proposals/pull/74---mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]-            -> (Int, [GlobalReg], CmmAGraph)-mkCallEntry dflags conv formals extra_stk-  = copyInOflow dflags conv Old formals extra_stk--lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]-             -> UpdFrameOffset-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)-             -> CmmAGraph-lastWithArgs dflags transfer area conv actuals updfr_off last =-  lastWithArgsAndExtraStack dflags transfer area conv actuals-                            updfr_off noExtraStack last--lastWithArgsAndExtraStack :: DynFlags-             -> Transfer -> Area -> Convention -> [CmmExpr]-             -> UpdFrameOffset -> [CmmExpr]-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)-             -> CmmAGraph-lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off-                          extra_stack last =-  copies <*> last outArgs regs- where-  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals-                               updfr_off extra_stack---noExtraStack :: [CmmExpr]-noExtraStack = []--toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff-       -> ByteOff -> [GlobalReg]-       -> CmmAGraph-toCall e cont updfr_off res_space arg_space regs =-  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
− compiler/cmm/PprC.hs 
@@ -1,1380 +0,0 @@-{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}------------------------------------------------------------------------------------- Pretty-printing of Cmm as C, suitable for feeding gcc------ (c) The University of Glasgow 2004-2006------ Print Cmm as real C, for -fvia-C------ See wiki:commentary/compiler/backends/ppr-c------ This is simpler than the old PprAbsC, because Cmm is "macro-expanded"--- relative to the old AbstractC, and many oddities/decorations have--- disappeared from the data type.------ This code generator is only supported in unregisterised mode.-----------------------------------------------------------------------------------module PprC (-        writeC-  ) where--#include "HsVersions.h"---- Cmm stuff-import GhcPrelude--import BlockId-import CLabel-import ForeignCall-import Cmm hiding (pprBBlock)-import PprCmm () -- For Outputable instances-import Hoopl.Block-import Hoopl.Collections-import Hoopl.Graph-import CmmUtils-import CmmSwitch---- Utils-import CPrim-import DynFlags-import FastString-import Outputable-import GHC.Platform-import UniqSet-import UniqFM-import Unique-import Util---- The rest-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Control.Monad.ST-import Data.Bits-import Data.Char-import Data.List-import Data.Map (Map)-import Data.Word-import System.IO-import qualified Data.Map as Map-import Control.Monad (ap)-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST---- ----------------------------------------------------------------------------- Top level--writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()-writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)---- ----------------------------------------------------------------------------- Now do some real work------ for fun, we could call cmmToCmm over the tops...-----pprC :: RawCmmGroup -> SDoc-pprC tops = vcat $ intersperse blankLine $ map pprTop tops------- top level procs----pprTop :: RawCmmDecl -> SDoc-pprTop (CmmProc infos clbl _in_live_regs graph) =--    (case mapLookup (g_entry graph) infos of-       Nothing -> empty-       Just (Statics info_clbl info_dat) ->-           pprDataExterns info_dat $$-           pprWordArray info_is_in_rodata info_clbl info_dat) $$-    (vcat [-           blankLine,-           extern_decls,-           (if (externallyVisibleCLabel clbl)-                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,-           nest 8 temp_decls,-           vcat (map pprBBlock blocks),-           rbrace ]-    )-  where-        -- info tables are always in .rodata-        info_is_in_rodata = True-        blocks = toBlockListEntryFirst graph-        (temp_decls, extern_decls) = pprTempAndExternDecls blocks----- Chunks of static data.---- We only handle (a) arrays of word-sized things and (b) strings.--pprTop (CmmData section (Statics lbl [CmmString str])) =-  pprExternDecl lbl $$-  hcat [-    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,-    text "[] = ", pprStringInCStyle str, semi-  ]--pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =-  pprExternDecl lbl $$-  hcat [-    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,-    brackets (int size), semi-  ]--pprTop (CmmData section (Statics lbl lits)) =-  pprDataExterns lits $$-  pprWordArray (isSecConstant section) lbl lits---- ----------------------------------------------------------------------------- BasicBlocks are self-contained entities: they always end in a jump.------ Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn--- as many jumps as possible into fall throughs.-----pprBBlock :: CmmBlock -> SDoc-pprBBlock block =-  nest 4 (pprBlockId (entryLabel block) <> colon) $$-  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)- where-  (_, nodes, last)  = blockSplit block---- ----------------------------------------------------------------------------- Info tables. Just arrays of words.--- See codeGen/ClosureInfo, and nativeGen/PprMach--pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc-pprWordArray is_ro lbl ds-  = sdocWithDynFlags $ \dflags ->-    -- TODO: align closures only-    pprExternDecl lbl $$-    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"-         , space, ppr lbl, text "[]"-         -- See Note [StgWord alignment]-         , pprAlignment (wordWidth dflags)-         , text "= {" ]-    $$ nest 8 (commafy (pprStatics dflags ds))-    $$ text "};"--pprAlignment :: Width -> SDoc-pprAlignment words =-     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"---- Note [StgWord alignment]--- C codegen builds static closures as StgWord C arrays (pprWordArray).--- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume--- pointers to 'StgClosure' are aligned at pointer size boundary:---  4 byte boundary on 32 systems---  and 8 bytes on 64-bit systems--- see TAG_MASK and TAG_BITS definition and usage.------ It's a reasonable assumption also known as natural alignment.--- Although some architectures have different alignment rules.--- One of known exceptions is m68k (#11395, comment:16) where:---   __alignof__(StgWord) == 2, sizeof(StgWord) == 4------ Thus we explicitly increase alignment by using---    __attribute__((aligned(4)))--- declaration.------- has to be static, if it isn't globally visible----pprLocalness :: CLabel -> SDoc-pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "-                 | otherwise = empty--pprConstness :: Bool -> SDoc-pprConstness is_ro | is_ro = text "const "-                   | otherwise = empty---- ----------------------------------------------------------------------------- Statements.-----pprStmt :: CmmNode e x -> SDoc--pprStmt stmt =-    sdocWithDynFlags $ \dflags ->-    case stmt of-    CmmEntry{}   -> empty-    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")-                          -- XXX if the string contains "*/", we need to fix it-                          -- XXX we probably want to emit these comments when-                          -- some debugging option is on.  They can get quite-                          -- large.--    CmmTick _ -> empty-    CmmUnwind{} -> empty--    CmmAssign dest src -> pprAssign dflags dest src--    CmmStore  dest src-        | typeWidth rep == W64 && wordWidth dflags /= W64-        -> (if isFloatType rep then text "ASSIGN_DBL"-                               else ptext (sLit ("ASSIGN_Word64"))) <>-           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi--        | otherwise-        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]-        where-          rep = cmmExprType dflags src--    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->-        fnCall-        where-        (res_hints, arg_hints) = foreignTargetHints target-        hresults = zip results res_hints-        hargs    = zip args arg_hints--        ForeignConvention cconv _ _ ret = conv--        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)--        -- See wiki:commentary/compiler/backends/ppr-c#prototypes-        fnCall =-            case fn of-              CmmLit (CmmLabel lbl)-                | StdCallConv <- cconv ->-                    pprCall (ppr lbl) cconv hresults hargs-                        -- stdcall functions must be declared with-                        -- a function type, otherwise the C compiler-                        -- doesn't add the @n suffix to the label.  We-                        -- can't add the @n suffix ourselves, because-                        -- it isn't valid C.-                | CmmNeverReturns <- ret ->-                    pprCall cast_fn cconv hresults hargs <> semi-                | not (isMathFun lbl) ->-                    pprForeignCall (ppr lbl) cconv hresults hargs-              _ ->-                    pprCall cast_fn cconv hresults hargs <> semi-                        -- for a dynamic call, no declaration is necessary.--    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty-    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty--    CmmUnsafeForeignCall target@(PrimTarget op) results args ->-        fn_call-      where-        cconv = CCallConv-        fn = pprCallishMachOp_for_C op--        (res_hints, arg_hints) = foreignTargetHints target-        hresults = zip results res_hints-        hargs    = zip args arg_hints--        fn_call-          -- The mem primops carry an extra alignment arg.-          -- We could maybe emit an alignment directive using this info.-          -- We also need to cast mem primops to prevent conflicts with GCC-          -- builtins (see bug #5967).-          | Just _align <- machOpMemcpyishAlign op-          = (text ";EFF_(" <> fn <> char ')' <> semi) $$-            pprForeignCall fn cconv hresults hargs-          | otherwise-          = pprCall fn cconv hresults hargs--    CmmBranch ident          -> pprBranch ident-    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no-    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi-    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->-                                pprSwitch dflags arg ids--    _other -> pprPanic "PprC.pprStmt" (ppr stmt)--type Hinted a = (a, ForeignHint)--pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]-               -> SDoc-pprForeignCall fn cconv results args = fn_call-  where-    fn_call = braces (-                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi-              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi-              $$ pprCall (text "ghcFunPtr") cconv results args <> semi-             )-    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)--pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprCFunType ppr_fn cconv ress args-  = sdocWithDynFlags $ \dflags ->-    let res_type [] = text "void"-        res_type [(one, hint)] = machRepHintCType (localRegType one) hint-        res_type _ = panic "pprCFunType: only void or 1 return value supported"--        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint-    in res_type ress <+>-       parens (ccallConvAttribute cconv <> ppr_fn) <>-       parens (commafy (map arg_type args))---- ------------------------------------------------------------------------ unconditional branches-pprBranch :: BlockId -> SDoc-pprBranch ident = text "goto" <+> pprBlockId ident <> semi----- ------------------------------------------------------------------------ conditional branches to local labels-pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc-pprCondBranch expr yes no-        = hsep [ text "if" , parens(pprExpr expr) ,-                        text "goto", pprBlockId yes <> semi,-                        text "else goto", pprBlockId no <> semi ]---- ------------------------------------------------------------------------ a local table branch------ we find the fall-through cases----pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc-pprSwitch dflags e ids-  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)-                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace-  where-    (pairs, mbdef) = switchTargetsFallThrough ids--    -- fall through case-    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix-        where-        do_fallthrough ix =-                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,-                        text "/* fall through */" ]--        final_branch ix =-                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,-                       text "goto" , (pprBlockId ident) <> semi ]--    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"--    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi-        | otherwise       = empty---- ------------------------------------------------------------------------ Expressions.------- C Types: the invariant is that the C expression generated by------      pprExpr e------ has a type in C which is also given by------      machRepCType (cmmExprType e)------ (similar invariants apply to the rest of the pretty printer).--pprExpr :: CmmExpr -> SDoc-pprExpr e = case e of-    CmmLit lit -> pprLit lit---    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty-    CmmReg reg      -> pprCastReg reg-    CmmRegOff reg 0 -> pprCastReg reg--    -- CmmRegOff is an alias of MO_Add-    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->-                       pprCastReg reg <> char '+' <>-                       pprHexVal (fromIntegral i) (wordWidth dflags)--    CmmMachOp mop args -> pprMachOpApp mop args--    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"---pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc-pprLoad dflags e ty-  | width == W64, wordWidth dflags /= W64-  = (if isFloatType ty then text "PK_DBL"-                       else text "PK_Word64")-    <> parens (mkP_ <> pprExpr1 e)--  | otherwise-  = case e of-        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)-                 -> char '*' <> pprAsPtrReg r--        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)-                      -> char '*' <> pprAsPtrReg r--        CmmRegOff r off | isPtrReg r && width == wordWidth dflags-                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)-        -- ToDo: check that the offset is a word multiple?-        --       (For tagging to work, I had to avoid unaligned loads. --ARY)-                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))--        _other -> cLoad e ty-  where-    width = typeWidth ty--pprExpr1 :: CmmExpr -> SDoc-pprExpr1 (CmmLit lit)     = pprLit1 lit-pprExpr1 e@(CmmReg _reg)  = pprExpr e-pprExpr1 other            = parens (pprExpr other)---- ----------------------------------------------------------------------------- MachOp applications--pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc--pprMachOpApp op args-  | isMulMayOfloOp op-  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))-  where isMulMayOfloOp (MO_U_MulMayOflo _) = True-        isMulMayOfloOp (MO_S_MulMayOflo _) = True-        isMulMayOfloOp _ = False--pprMachOpApp mop args-  | Just ty <- machOpNeedsCast mop-  = ty <> parens (pprMachOpApp' mop args)-  | otherwise-  = pprMachOpApp' mop args---- Comparisons in C have type 'int', but we want type W_ (this is what--- resultRepOfMachOp says).  The other C operations inherit their type--- from their operands, so no casting is required.-machOpNeedsCast :: MachOp -> Maybe SDoc-machOpNeedsCast mop-  | isComparisonMachOp mop = Just mkW_-  | otherwise              = Nothing--pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc-pprMachOpApp' mop args- = case args of-    -- dyadic-    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y--    -- unary-    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)--    _     -> panic "PprC.pprMachOp : machop with wrong number of args"--  where-        -- Cast needed for signed integer ops-    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->-                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e-             | needsFCasts mop = sdocWithDynFlags $ \dflags ->-                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e-             | otherwise    = pprExpr1 e-    needsFCasts (MO_F_Eq _)   = False-    needsFCasts (MO_F_Ne _)   = False-    needsFCasts (MO_F_Neg _)  = True-    needsFCasts (MO_F_Quot _) = True-    needsFCasts mop  = floatComparison mop---- ----------------------------------------------------------------------------- Literals--pprLit :: CmmLit -> SDoc-pprLit lit = case lit of-    CmmInt i rep      -> pprHexVal i rep--    CmmFloat f w       -> parens (machRep_F_CType w) <> str-        where d = fromRational f :: Double-              str | isInfinite d && d < 0 = text "-INFINITY"-                  | isInfinite d          = text "INFINITY"-                  | isNaN d               = text "NAN"-                  | otherwise             = text (show d)-                -- these constants come from <math.h>-                -- see #1861--    CmmVec {} -> panic "PprC printing vector literal"--    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)-    CmmHighStackMark   -> panic "PprC printing high stack mark"-    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl-    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i-    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C-        -- WARNING:-        --  * the lit must occur in the info table clbl2-        --  * clbl1 must be an SRT, a slow entry point or a large bitmap-        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i--    where-        pprCLabelAddr lbl = char '&' <> ppr lbl--pprLit1 :: CmmLit -> SDoc-pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)-pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)-pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)-pprLit1 other = pprLit other---- ------------------------------------------------------------------------------ Static data--pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]-pprStatics _ [] = []-pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)-  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding-  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest-  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'-  -- adjacent floats aren't padded but combined into a single word-  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest-  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'-  | wORD_SIZE dflags == 4-  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest-  | otherwise-  = pprPanic "pprStatics: float" (vcat (map ppr' rest))-    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->-                                  ppr (cmmLitType dflags l)-          ppr' _other           = text "bad static!"-pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)-  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest--pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)-  | wordWidth dflags == W32-  = if wORDS_BIGENDIAN dflags-    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :-                            CmmStaticLit (CmmInt r W32) : rest)-    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :-                            CmmStaticLit (CmmInt q W32) : rest)-  where r = i .&. 0xffffffff-        q = i `shiftR` 32-pprStatics dflags (CmmStaticLit (CmmInt a W32) :-                   CmmStaticLit (CmmInt b W32) : rest)-  | wordWidth dflags == W64-  = if wORDS_BIGENDIAN dflags-    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :-                            rest)-    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :-                            rest)-pprStatics dflags (CmmStaticLit (CmmInt a W16) :-                   CmmStaticLit (CmmInt b W16) : rest)-  | wordWidth dflags == W32-  = if wORDS_BIGENDIAN dflags-    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :-                            rest)-    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :-                            rest)-pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)-  | w /= wordWidth dflags-  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)-pprStatics dflags (CmmStaticLit lit : rest)-  = pprLit1 lit : pprStatics dflags rest-pprStatics _ (other : _)-  = pprPanic "pprStatics: other" (pprStatic other)--pprStatic :: CmmStatic -> SDoc-pprStatic s = case s of--    CmmStaticLit lit   -> nest 4 (pprLit lit)-    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))--    -- these should be inlined, like the old .hc-    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))----- ------------------------------------------------------------------------------ Block Ids--pprBlockId :: BlockId -> SDoc-pprBlockId b = char '_' <> ppr (getUnique b)---- ----------------------------------------------------------------------------- Print a MachOp in a way suitable for emitting via C.-----pprMachOp_for_C :: MachOp -> SDoc--pprMachOp_for_C mop = case mop of--        -- Integer operations-        MO_Add          _ -> char '+'-        MO_Sub          _ -> char '-'-        MO_Eq           _ -> text "=="-        MO_Ne           _ -> text "!="-        MO_Mul          _ -> char '*'--        MO_S_Quot       _ -> char '/'-        MO_S_Rem        _ -> char '%'-        MO_S_Neg        _ -> char '-'--        MO_U_Quot       _ -> char '/'-        MO_U_Rem        _ -> char '%'--        -- & Floating-point operations-        MO_F_Add        _ -> char '+'-        MO_F_Sub        _ -> char '-'-        MO_F_Neg        _ -> char '-'-        MO_F_Mul        _ -> char '*'-        MO_F_Quot       _ -> char '/'--        -- Signed comparisons-        MO_S_Ge         _ -> text ">="-        MO_S_Le         _ -> text "<="-        MO_S_Gt         _ -> char '>'-        MO_S_Lt         _ -> char '<'--        -- & Unsigned comparisons-        MO_U_Ge         _ -> text ">="-        MO_U_Le         _ -> text "<="-        MO_U_Gt         _ -> char '>'-        MO_U_Lt         _ -> char '<'--        -- & Floating-point comparisons-        MO_F_Eq         _ -> text "=="-        MO_F_Ne         _ -> text "!="-        MO_F_Ge         _ -> text ">="-        MO_F_Le         _ -> text "<="-        MO_F_Gt         _ -> char '>'-        MO_F_Lt         _ -> char '<'--        -- Bitwise operations.  Not all of these may be supported at all-        -- sizes, and only integral MachReps are valid.-        MO_And          _ -> char '&'-        MO_Or           _ -> char '|'-        MO_Xor          _ -> char '^'-        MO_Not          _ -> char '~'-        MO_Shl          _ -> text "<<"-        MO_U_Shr        _ -> text ">>" -- unsigned shift right-        MO_S_Shr        _ -> text ">>" -- signed shift right---- Conversions.  Some of these will be NOPs, but never those that convert--- between ints and floats.--- Floating-point conversions use the signed variant.--- We won't know to generate (void*) casts here, but maybe from--- context elsewhere---- noop casts-        MO_UU_Conv from to | from == to -> empty-        MO_UU_Conv _from to -> parens (machRep_U_CType to)--        MO_SS_Conv from to | from == to -> empty-        MO_SS_Conv _from to -> parens (machRep_S_CType to)--        MO_XX_Conv from to | from == to -> empty-        MO_XX_Conv _from to -> parens (machRep_U_CType to)--        MO_FF_Conv from to | from == to -> empty-        MO_FF_Conv _from to -> parens (machRep_F_CType to)--        MO_SF_Conv _from to -> parens (machRep_F_CType to)-        MO_FS_Conv _from to -> parens (machRep_S_CType to)--        MO_S_MulMayOflo _ -> pprTrace "offending mop:"-                                (text "MO_S_MulMayOflo")-                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"-                                      ++ " should have been handled earlier!")-        MO_U_MulMayOflo _ -> pprTrace "offending mop:"-                                (text "MO_U_MulMayOflo")-                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"-                                      ++ " should have been handled earlier!")--        MO_V_Insert {}    -> pprTrace "offending mop:"-                                (text "MO_V_Insert")-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"-                                      ++ " should have been handled earlier!")-        MO_V_Extract {}   -> pprTrace "offending mop:"-                                (text "MO_V_Extract")-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"-                                      ++ " should have been handled earlier!")--        MO_V_Add {}       -> pprTrace "offending mop:"-                                (text "MO_V_Add")-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"-                                      ++ " should have been handled earlier!")-        MO_V_Sub {}       -> pprTrace "offending mop:"-                                (text "MO_V_Sub")-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"-                                      ++ " should have been handled earlier!")-        MO_V_Mul {}       -> pprTrace "offending mop:"-                                (text "MO_V_Mul")-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"-                                      ++ " should have been handled earlier!")--        MO_VS_Quot {}     -> pprTrace "offending mop:"-                                (text "MO_VS_Quot")-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"-                                      ++ " should have been handled earlier!")-        MO_VS_Rem {}      -> pprTrace "offending mop:"-                                (text "MO_VS_Rem")-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"-                                      ++ " should have been handled earlier!")-        MO_VS_Neg {}      -> pprTrace "offending mop:"-                                (text "MO_VS_Neg")-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"-                                      ++ " should have been handled earlier!")--        MO_VU_Quot {}     -> pprTrace "offending mop:"-                                (text "MO_VU_Quot")-                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"-                                      ++ " should have been handled earlier!")-        MO_VU_Rem {}      -> pprTrace "offending mop:"-                                (text "MO_VU_Rem")-                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"-                                      ++ " should have been handled earlier!")--        MO_VF_Insert {}   -> pprTrace "offending mop:"-                                (text "MO_VF_Insert")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"-                                      ++ " should have been handled earlier!")-        MO_VF_Extract {}  -> pprTrace "offending mop:"-                                (text "MO_VF_Extract")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"-                                      ++ " should have been handled earlier!")--        MO_VF_Add {}      -> pprTrace "offending mop:"-                                (text "MO_VF_Add")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"-                                      ++ " should have been handled earlier!")-        MO_VF_Sub {}      -> pprTrace "offending mop:"-                                (text "MO_VF_Sub")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"-                                      ++ " should have been handled earlier!")-        MO_VF_Neg {}      -> pprTrace "offending mop:"-                                (text "MO_VF_Neg")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"-                                      ++ " should have been handled earlier!")-        MO_VF_Mul {}      -> pprTrace "offending mop:"-                                (text "MO_VF_Mul")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"-                                      ++ " should have been handled earlier!")-        MO_VF_Quot {}     -> pprTrace "offending mop:"-                                (text "MO_VF_Quot")-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"-                                      ++ " should have been handled earlier!")--        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"--signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints-signedOp (MO_S_Quot _)    = True-signedOp (MO_S_Rem  _)    = True-signedOp (MO_S_Neg  _)    = True-signedOp (MO_S_Ge   _)    = True-signedOp (MO_S_Le   _)    = True-signedOp (MO_S_Gt   _)    = True-signedOp (MO_S_Lt   _)    = True-signedOp (MO_S_Shr  _)    = True-signedOp (MO_SS_Conv _ _) = True-signedOp (MO_SF_Conv _ _) = True-signedOp _                = False--floatComparison :: MachOp -> Bool  -- comparison between float args-floatComparison (MO_F_Eq   _) = True-floatComparison (MO_F_Ne   _) = True-floatComparison (MO_F_Ge   _) = True-floatComparison (MO_F_Le   _) = True-floatComparison (MO_F_Gt   _) = True-floatComparison (MO_F_Lt   _) = True-floatComparison _             = False---- ------------------------------------------------------------------------ tend to be implemented by foreign calls--pprCallishMachOp_for_C :: CallishMachOp -> SDoc--pprCallishMachOp_for_C mop-    = case mop of-        MO_F64_Pwr      -> text "pow"-        MO_F64_Sin      -> text "sin"-        MO_F64_Cos      -> text "cos"-        MO_F64_Tan      -> text "tan"-        MO_F64_Sinh     -> text "sinh"-        MO_F64_Cosh     -> text "cosh"-        MO_F64_Tanh     -> text "tanh"-        MO_F64_Asin     -> text "asin"-        MO_F64_Acos     -> text "acos"-        MO_F64_Atanh    -> text "atanh"-        MO_F64_Asinh    -> text "asinh"-        MO_F64_Acosh    -> text "acosh"-        MO_F64_Atan     -> text "atan"-        MO_F64_Log      -> text "log"-        MO_F64_Log1P    -> text "log1p"-        MO_F64_Exp      -> text "exp"-        MO_F64_ExpM1    -> text "expm1"-        MO_F64_Sqrt     -> text "sqrt"-        MO_F64_Fabs     -> text "fabs"-        MO_F32_Pwr      -> text "powf"-        MO_F32_Sin      -> text "sinf"-        MO_F32_Cos      -> text "cosf"-        MO_F32_Tan      -> text "tanf"-        MO_F32_Sinh     -> text "sinhf"-        MO_F32_Cosh     -> text "coshf"-        MO_F32_Tanh     -> text "tanhf"-        MO_F32_Asin     -> text "asinf"-        MO_F32_Acos     -> text "acosf"-        MO_F32_Atan     -> text "atanf"-        MO_F32_Asinh    -> text "asinhf"-        MO_F32_Acosh    -> text "acoshf"-        MO_F32_Atanh    -> text "atanhf"-        MO_F32_Log      -> text "logf"-        MO_F32_Log1P    -> text "log1pf"-        MO_F32_Exp      -> text "expf"-        MO_F32_ExpM1    -> text "expm1f"-        MO_F32_Sqrt     -> text "sqrtf"-        MO_F32_Fabs     -> text "fabsf"-        MO_ReadBarrier  -> text "load_load_barrier"-        MO_WriteBarrier -> text "write_barrier"-        MO_Memcpy _     -> text "memcpy"-        MO_Memset _     -> text "memset"-        MO_Memmove _    -> text "memmove"-        MO_Memcmp _     -> text "memcmp"-        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)-        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)-        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)-        (MO_Pext w)     -> ptext (sLit $ pextLabel w)-        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)-        (MO_Clz w)      -> ptext (sLit $ clzLabel w)-        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)-        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)-        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)-        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)-        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)-        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)--        MO_S_Mul2     {} -> unsupported-        MO_S_QuotRem  {} -> unsupported-        MO_U_QuotRem  {} -> unsupported-        MO_U_QuotRem2 {} -> unsupported-        MO_Add2       {} -> unsupported-        MO_AddWordC   {} -> unsupported-        MO_SubWordC   {} -> unsupported-        MO_AddIntC    {} -> unsupported-        MO_SubIntC    {} -> unsupported-        MO_U_Mul2     {} -> unsupported-        MO_Touch         -> unsupported-        (MO_Prefetch_Data _ ) -> unsupported-        --- we could support prefetch via "__builtin_prefetch"-        --- Not adding it for now-    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop-                            ++ " not supported!")---- ------------------------------------------------------------------------ Useful #defines-----mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc--mkJMP_ i = text "JMP_" <> parens i-mkFN_  i = text "FN_"  <> parens i -- externally visible function-mkIF_  i = text "IF_"  <> parens i -- locally visible---- from includes/Stg.h----mkC_,mkW_,mkP_ :: SDoc--mkC_  = text "(C_)"        -- StgChar-mkW_  = text "(W_)"        -- StgWord-mkP_  = text "(P_)"        -- StgWord*---- --------------------------------------------------------------------------- Assignments------ Generating assignments is what we're all about, here----pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc---- dest is a reg, rhs is a reg-pprAssign _ r1 (CmmReg r2)-   | isPtrReg r1 && isPtrReg r2-   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]---- dest is a reg, rhs is a CmmRegOff-pprAssign dflags r1 (CmmRegOff r2 off)-   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)-   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]-  where-        off1 = off `shiftR` wordShift dflags--        (op,off') | off >= 0  = (char '+', off1)-                  | otherwise = (char '-', -off1)---- dest is a reg, rhs is anything.--- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting--- the lvalue elicits a warning from new GCC versions (3.4+).-pprAssign _ r1 r2-  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)-  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)-  | otherwise                    = mkAssign (pprExpr r2)-    where mkAssign x = if r1 == CmmGlobal BaseReg-                       then text "ASSIGN_BaseReg" <> parens x <> semi-                       else pprReg r1 <> text " = " <> x <> semi---- ------------------------------------------------------------------------ Registers--pprCastReg :: CmmReg -> SDoc-pprCastReg reg-   | isStrangeTypeReg reg = mkW_ <> pprReg reg-   | otherwise            = pprReg reg---- True if (pprReg reg) will give an expression with type StgPtr.  We--- need to take care with pointer arithmetic on registers with type--- StgPtr.-isFixedPtrReg :: CmmReg -> Bool-isFixedPtrReg (CmmLocal _) = False-isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r---- True if (pprAsPtrReg reg) will give an expression with type StgPtr--- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.--- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;--- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.-isPtrReg :: CmmReg -> Bool-isPtrReg (CmmLocal _)                         = False-isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg-isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg-isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg---- True if this global reg has type StgPtr-isFixedPtrGlobalReg :: GlobalReg -> Bool-isFixedPtrGlobalReg Sp    = True-isFixedPtrGlobalReg Hp    = True-isFixedPtrGlobalReg HpLim = True-isFixedPtrGlobalReg SpLim = True-isFixedPtrGlobalReg _     = False---- True if in C this register doesn't have the type given by--- (machRepCType (cmmRegType reg)), so it has to be cast.-isStrangeTypeReg :: CmmReg -> Bool-isStrangeTypeReg (CmmLocal _)   = False-isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g--isStrangeTypeGlobal :: GlobalReg -> Bool-isStrangeTypeGlobal CCCS                = True-isStrangeTypeGlobal CurrentTSO          = True-isStrangeTypeGlobal CurrentNursery      = True-isStrangeTypeGlobal BaseReg             = True-isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r--strangeRegType :: CmmReg -> Maybe SDoc-strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")-strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")-strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")-strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")-strangeRegType _ = Nothing---- pprReg just prints the register name.----pprReg :: CmmReg -> SDoc-pprReg r = case r of-        CmmLocal  local  -> pprLocalReg local-        CmmGlobal global -> pprGlobalReg global--pprAsPtrReg :: CmmReg -> SDoc-pprAsPtrReg (CmmGlobal (VanillaReg n gcp))-  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"-pprAsPtrReg other_reg = pprReg other_reg--pprGlobalReg :: GlobalReg -> SDoc-pprGlobalReg gr = case gr of-    VanillaReg n _ -> char 'R' <> int n  <> text ".w"-        -- pprGlobalReg prints a VanillaReg as a .w regardless-        -- Example:     R1.w = R1.w & (-0x8UL);-        --              JMP_(*R1.p);-    FloatReg   n   -> char 'F' <> int n-    DoubleReg  n   -> char 'D' <> int n-    LongReg    n   -> char 'L' <> int n-    Sp             -> text "Sp"-    SpLim          -> text "SpLim"-    Hp             -> text "Hp"-    HpLim          -> text "HpLim"-    CCCS           -> text "CCCS"-    CurrentTSO     -> text "CurrentTSO"-    CurrentNursery -> text "CurrentNursery"-    HpAlloc        -> text "HpAlloc"-    BaseReg        -> text "BaseReg"-    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"-    GCEnter1       -> text "stg_gc_enter_1"-    GCFun          -> text "stg_gc_fun"-    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other--pprLocalReg :: LocalReg -> SDoc-pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq---- -------------------------------------------------------------------------------- Foreign Calls--pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprCall ppr_fn cconv results args-  | not (is_cishCC cconv)-  = panic $ "pprCall: unknown calling convention"--  | otherwise-  =-    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi-  where-     ppr_assign []           rhs = rhs-     ppr_assign [(one,hint)] rhs-         = pprLocalReg one <> text " = "-                 <> pprUnHint hint (localRegType one) <> rhs-     ppr_assign _other _rhs = panic "pprCall: multiple results"--     pprArg (expr, AddrHint)-        = cCast (text "void *") expr-        -- see comment by machRepHintCType below-     pprArg (expr, SignedHint)-        = sdocWithDynFlags $ \dflags ->-          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr-     pprArg (expr, _other)-        = pprExpr expr--     pprUnHint AddrHint   rep = parens (machRepCType rep)-     pprUnHint SignedHint rep = parens (machRepCType rep)-     pprUnHint _          _   = empty---- Currently we only have these two calling conventions, but this might--- change in the future...-is_cishCC :: CCallConv -> Bool-is_cishCC CCallConv    = True-is_cishCC CApiConv     = True-is_cishCC StdCallConv  = True-is_cishCC PrimCallConv = False-is_cishCC JavaScriptCallConv = False---- ------------------------------------------------------------------------ Find and print local and external declarations for a list of--- Cmm statements.----pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})-pprTempAndExternDecls stmts-  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),-     vcat (map pprExternDecl (Map.keys lbls)))-  where (temps, lbls) = runTE (mapM_ te_BB stmts)--pprDataExterns :: [CmmStatic] -> SDoc-pprDataExterns statics-  = vcat (map pprExternDecl (Map.keys lbls))-  where (_, lbls) = runTE (mapM_ te_Static statics)--pprTempDecl :: LocalReg -> SDoc-pprTempDecl l@(LocalReg _ rep)-  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]--pprExternDecl :: CLabel -> SDoc-pprExternDecl lbl-  -- do not print anything for "known external" things-  | not (needsCDecl lbl) = empty-  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz-  | otherwise =-        hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"-             -- occasionally useful to see label type-             -- , text "/* ", pprDebugCLabel lbl, text " */"-             ]- where-  label_type lbl | isBytesLabel lbl         = text "B_"-                 | isForeignLabel lbl && isCFunctionLabel lbl-                                            = text "FF_"-                 | isCFunctionLabel lbl     = text "F_"-                 | isStaticClosureLabel lbl = text "C_"-                 -- generic .rodata labels-                 | isSomeRODataLabel lbl    = text "RO_"-                 -- generic .data labels (common case)-                 | otherwise                = text "RW_"--  visibility-     | externallyVisibleCLabel lbl = char 'E'-     | otherwise                   = char 'I'--  -- If the label we want to refer to is a stdcall function (on Windows) then-  -- we must generate an appropriate prototype for it, so that the C compiler will-  -- add the @n suffix to the label (#2276)-  stdcall_decl sz = sdocWithDynFlags $ \dflags ->-        text "extern __attribute__((stdcall)) void " <> ppr lbl-        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))-        <> semi--type TEState = (UniqSet LocalReg, Map CLabel ())-newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)--instance Applicative TE where-      pure a = TE $ \s -> (a, s)-      (<*>) = ap--instance Monad TE where-   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'--te_lbl :: CLabel -> TE ()-te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))--te_temp :: LocalReg -> TE ()-te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))--runTE :: TE () -> TEState-runTE (TE m) = snd (m (emptyUniqSet, Map.empty))--te_Static :: CmmStatic -> TE ()-te_Static (CmmStaticLit lit) = te_Lit lit-te_Static _ = return ()--te_BB :: CmmBlock -> TE ()-te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last-  where (_, mid, last) = blockSplit block--te_Lit :: CmmLit -> TE ()-te_Lit (CmmLabel l) = te_lbl l-te_Lit (CmmLabelOff l _) = te_lbl l-te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1-te_Lit _ = return ()--te_Stmt :: CmmNode e x -> TE ()-te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e-te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r-te_Stmt (CmmUnsafeForeignCall target rs es)-  = do  te_Target target-        mapM_ te_temp rs-        mapM_ te_Expr es-te_Stmt (CmmCondBranch e _ _ _) = te_Expr e-te_Stmt (CmmSwitch e _)         = te_Expr e-te_Stmt (CmmCall { cml_target = e }) = te_Expr e-te_Stmt _                       = return ()--te_Target :: ForeignTarget -> TE ()-te_Target (ForeignTarget e _)      = te_Expr e-te_Target (PrimTarget{})           = return ()--te_Expr :: CmmExpr -> TE ()-te_Expr (CmmLit lit)            = te_Lit lit-te_Expr (CmmLoad e _)           = te_Expr e-te_Expr (CmmReg r)              = te_Reg r-te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es-te_Expr (CmmRegOff r _)         = te_Reg r-te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"--te_Reg :: CmmReg -> TE ()-te_Reg (CmmLocal l) = te_temp l-te_Reg _            = return ()----- ------------------------------------------------------------------------ C types for MachReps--cCast :: SDoc -> CmmExpr -> SDoc-cCast ty expr = parens ty <> pprExpr1 expr--cLoad :: CmmExpr -> CmmType -> SDoc-cLoad expr rep-    = sdocWithPlatform $ \platform ->-      if bewareLoadStoreAlignment (platformArch platform)-      then let decl = machRepCType rep <+> text "x" <> semi-               struct = text "struct" <+> braces (decl)-               packed_attr = text "__attribute__((packed))"-               cast = parens (struct <+> packed_attr <> char '*')-           in parens (cast <+> pprExpr1 expr) <> text "->x"-      else char '*' <> parens (cCast (machRepPtrCType rep) expr)-    where -- On these platforms, unaligned loads are known to cause problems-          bewareLoadStoreAlignment ArchAlpha    = True-          bewareLoadStoreAlignment ArchMipseb   = True-          bewareLoadStoreAlignment ArchMipsel   = True-          bewareLoadStoreAlignment (ArchARM {}) = True-          bewareLoadStoreAlignment ArchARM64    = True-          bewareLoadStoreAlignment ArchSPARC    = True-          bewareLoadStoreAlignment ArchSPARC64  = True-          -- Pessimistically assume that they will also cause problems-          -- on unknown arches-          bewareLoadStoreAlignment ArchUnknown  = True-          bewareLoadStoreAlignment _            = False--isCmmWordType :: DynFlags -> CmmType -> Bool--- True of GcPtrReg/NonGcReg of native word size-isCmmWordType dflags ty = not (isFloatType ty)-                       && typeWidth ty == wordWidth dflags---- This is for finding the types of foreign call arguments.  For a pointer--- argument, we always cast the argument to (void *), to avoid warnings from--- the C compiler.-machRepHintCType :: CmmType -> ForeignHint -> SDoc-machRepHintCType _   AddrHint   = text "void *"-machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)-machRepHintCType rep _other     = machRepCType rep--machRepPtrCType :: CmmType -> SDoc-machRepPtrCType r- = sdocWithDynFlags $ \dflags ->-   if isCmmWordType dflags r then text "P_"-                             else machRepCType r <> char '*'--machRepCType :: CmmType -> SDoc-machRepCType ty | isFloatType ty = machRep_F_CType w-                | otherwise      = machRep_U_CType w-                where-                  w = typeWidth ty--machRep_F_CType :: Width -> SDoc-machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?-machRep_F_CType W64 = text "StgDouble"-machRep_F_CType _   = panic "machRep_F_CType"--machRep_U_CType :: Width -> SDoc-machRep_U_CType w- = sdocWithDynFlags $ \dflags ->-   case w of-   _ | w == wordWidth dflags -> text "W_"-   W8  -> text "StgWord8"-   W16 -> text "StgWord16"-   W32 -> text "StgWord32"-   W64 -> text "StgWord64"-   _   -> panic "machRep_U_CType"--machRep_S_CType :: Width -> SDoc-machRep_S_CType w- = sdocWithDynFlags $ \dflags ->-   case w of-   _ | w == wordWidth dflags -> text "I_"-   W8  -> text "StgInt8"-   W16 -> text "StgInt16"-   W32 -> text "StgInt32"-   W64 -> text "StgInt64"-   _   -> panic "machRep_S_CType"----- ------------------------------------------------------------------------ print strings as valid C strings--pprStringInCStyle :: ByteString -> SDoc-pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))---- ------------------------------------------------------------------------------ Initialising static objects with floating-point numbers.  We can't--- just emit the floating point number, because C will cast it to an int--- by rounding it.  We want the actual bit-representation of the float.------ Consider a concrete C example:---    double d = 2.5e-10;---    float f  = 2.5e-10f;------    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);---    long long * l = &d; printf (" l: %016llX\n",   l[0]);---    int * i = &f;       printf (" i: %08X\n",      i[0]);--- Result on 64-bit LE (x86_64):---     i2: E826D695 3DF12E0B---      l: 3DF12E0BE826D695---      i: 2F89705F--- Result on 32-bit BE (m68k):---     i2: 3DF12E0B E826D695---      l: 3DF12E0BE826D695---      i: 2F89705F------ The trick here is to notice that binary representation does not--- change much: only Word32 values get swapped on LE hosts / targets.---- This is a hack to turn the floating point numbers into ints that we--- can safely initialise to static locations.--castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)-castFloatToWord32Array = U.castSTUArray--castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)-castDoubleToWord64Array = U.castSTUArray--floatToWord :: DynFlags -> Rational -> CmmLit-floatToWord dflags r-  = runST (do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 (fromRational r)-        arr' <- castFloatToWord32Array arr-        w32 <- readArray arr' 0-        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))-    )-    where wo | wordWidth dflags == W64-             , wORDS_BIGENDIAN dflags    = 32-             | otherwise                 = 0--floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit-floatPairToWord dflags r1 r2-  = runST (do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r1)-        writeArray arr 1 (fromRational r2)-        arr' <- castFloatToWord32Array arr-        w32_1 <- readArray arr' 0-        w32_2 <- readArray arr' 1-        return (pprWord32Pair w32_1 w32_2)-    )-    where pprWord32Pair w32_1 w32_2-              | wORDS_BIGENDIAN dflags =-                  CmmInt ((shiftL i1 32) .|. i2) W64-              | otherwise =-                  CmmInt ((shiftL i2 32) .|. i1) W64-              where i1 = toInteger w32_1-                    i2 = toInteger w32_2--doubleToWords :: DynFlags -> Rational -> [CmmLit]-doubleToWords dflags r-  = runST (do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r)-        arr' <- castDoubleToWord64Array arr-        w64 <- readArray arr' 0-        return (pprWord64 w64)-    )-    where targetWidth = wordWidth dflags-          targetBE    = wORDS_BIGENDIAN dflags-          pprWord64 w64-              | targetWidth == W64 =-                  [ CmmInt (toInteger w64) targetWidth ]-              | targetWidth == W32 =-                  [ CmmInt (toInteger targetW1) targetWidth-                  , CmmInt (toInteger targetW2) targetWidth-                  ]-              | otherwise = panic "doubleToWords.pprWord64"-              where (targetW1, targetW2)-                        | targetBE  = (wHi, wLo)-                        | otherwise = (wLo, wHi)-                    wHi = w64 `shiftR` 32-                    wLo = w64 .&. 0xFFFFffff---- ------------------------------------------------------------------------------ Utils--wordShift :: DynFlags -> Int-wordShift dflags = widthInLog (wordWidth dflags)--commafy :: [SDoc] -> SDoc-commafy xs = hsep $ punctuate comma xs---- Print in C hex format: 0x13fa-pprHexVal :: Integer -> Width -> SDoc-pprHexVal w rep-  | w < 0     = parens (char '-' <>-                    text "0x" <> intToDoc (-w) <> repsuffix rep)-  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep-  where-        -- type suffix for literals:-        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to-        -- signed values for doing signed operations, but at all other-        -- times values are unsigned.  This also helps eliminate occasional-        -- warnings about integer overflow from gcc.--      repsuffix W64 = sdocWithDynFlags $ \dflags ->-               if cINT_SIZE       dflags == 8 then char 'U'-          else if cLONG_SIZE      dflags == 8 then text "UL"-          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"-          else panic "pprHexVal: Can't find a 64-bit type"-      repsuffix _ = char 'U'--      intToDoc :: Integer -> SDoc-      intToDoc i = case truncInt i of-                       0 -> char '0'-                       v -> go v--      -- We need to truncate value as Cmm backend does not drop-      -- redundant bits to ease handling of negative values.-      -- Thus the following Cmm code on 64-bit arch, like amd64:-      --     CInt v;-      --     v = {something};-      --     if (v == %lobits32(-1)) { ...-      -- leads to the following C code:-      --     StgWord64 v = (StgWord32)({something});-      --     if (v == 0xFFFFffffFFFFffffU) { ...-      -- Such code is incorrect as it promotes both operands to StgWord64-      -- and the whole condition is always false.-      truncInt :: Integer -> Integer-      truncInt i =-          case rep of-              W8  -> i `rem` (2^(8 :: Int))-              W16 -> i `rem` (2^(16 :: Int))-              W32 -> i `rem` (2^(32 :: Int))-              W64 -> i `rem` (2^(64 :: Int))-              _   -> panic ("pprHexVal/truncInt: C backend can't encode "-                            ++ show rep ++ " literals")--      go 0 = empty-      go w' = go q <> dig-           where-             (q,r) = w' `quotRem` 16-             dig | r < 10    = char (chr (fromInteger r + ord '0'))-                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
− compiler/cmm/PprCmm.hs 
@@ -1,309 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}------------------------------------------------------------------------------------ Pretty-printing of Cmm as (a superset of) C-------- (c) The University of Glasgow 2004-2006--------------------------------------------------------------------------------------- This is where we walk over CmmNode emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:---      1) if a value has wordRep type, the type is not appended in the---      output.---      2) MachOps that operate over wordRep type are printed in a---      C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs--module PprCmm-  ( module PprCmmDecl-  , module PprCmmExpr-  )-where--import GhcPrelude hiding (succ)--import CLabel-import Cmm-import CmmUtils-import CmmSwitch-import DynFlags-import FastString-import Outputable-import PprCmmDecl-import PprCmmExpr-import Util--import BasicTypes-import Hoopl.Block-import Hoopl.Graph------------------------------------------------------ Outputable instances--instance Outputable CmmStackInfo where-    ppr = pprStackInfo--instance Outputable CmmTopInfo where-    ppr = pprTopInfo---instance Outputable (CmmNode e x) where-    ppr = pprNode--instance Outputable Convention where-    ppr = pprConvention--instance Outputable ForeignConvention where-    ppr = pprForeignConvention--instance Outputable ForeignTarget where-    ppr = pprForeignTarget--instance Outputable CmmReturnInfo where-    ppr = pprReturnInfo--instance Outputable (Block CmmNode C C) where-    ppr = pprBlock-instance Outputable (Block CmmNode C O) where-    ppr = pprBlock-instance Outputable (Block CmmNode O C) where-    ppr = pprBlock-instance Outputable (Block CmmNode O O) where-    ppr = pprBlock--instance Outputable (Graph CmmNode e x) where-    ppr = pprGraph--instance Outputable CmmGraph where-    ppr = pprCmmGraph--------------------------------------------------------------- Outputting types Cmm contains--pprStackInfo :: CmmStackInfo -> SDoc-pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =-  text "arg_space: " <> ppr arg_space <+>-  text "updfr_space: " <> ppr updfr_space--pprTopInfo :: CmmTopInfo -> SDoc-pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =-  vcat [text "info_tbls: " <> ppr info_tbl,-        text "stack_info: " <> ppr stack_info]--------------------------------------------------------------- Outputting blocks and graphs--pprBlock :: IndexedCO x SDoc SDoc ~ SDoc-         => Block CmmNode e x -> IndexedCO e SDoc SDoc-pprBlock block-    = foldBlockNodesB3 ( ($$) . ppr-                       , ($$) . (nest 4) . ppr-                       , ($$) . (nest 4) . ppr-                       )-                       block-                       empty--pprGraph :: Graph CmmNode e x -> SDoc-pprGraph GNil = empty-pprGraph (GUnit block) = ppr block-pprGraph (GMany entry body exit)-   = text "{"-  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)-  $$ text "}"-  where pprMaybeO :: Outputable (Block CmmNode e x)-                  => MaybeO ex (Block CmmNode e x) -> SDoc-        pprMaybeO NothingO = empty-        pprMaybeO (JustO block) = ppr block--pprCmmGraph :: CmmGraph -> SDoc-pprCmmGraph g-   = text "{" <> text "offset"-  $$ nest 2 (vcat $ map ppr blocks)-  $$ text "}"-  where blocks = revPostorder g-    -- revPostorder has the side-effect of discarding unreachable code,-    -- so pretty-printed Cmm will omit any unreachable blocks.  This can-    -- sometimes be confusing.-------------------------------------------------- Outputting CmmNode and types which it contains--pprConvention :: Convention -> SDoc-pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"-pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"-pprConvention (NativeReturn {})     = text "<native-ret-convention>"-pprConvention  Slow                 = text "<slow-convention>"-pprConvention  GC                   = text "<gc-convention>"--pprForeignConvention :: ForeignConvention -> SDoc-pprForeignConvention (ForeignConvention c args res ret) =-          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret--pprReturnInfo :: CmmReturnInfo -> SDoc-pprReturnInfo CmmMayReturn = empty-pprReturnInfo CmmNeverReturns = text "never returns"--pprForeignTarget :: ForeignTarget -> SDoc-pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn-  where-        ppr_target :: CmmExpr -> SDoc-        ppr_target t@(CmmLit _) = ppr t-        ppr_target fn'          = parens (ppr fn')--pprForeignTarget (PrimTarget op)- -- HACK: We're just using a ForeignLabel to get this printed, the label- --       might not really be foreign.- = ppr-               (CmmLabel (mkForeignLabel-                         (mkFastString (show op))-                         Nothing ForeignLabelInThisPackage IsFunction))--pprNode :: CmmNode e x -> SDoc-pprNode node = pp_node <+> pp_debug-  where-    pp_node :: SDoc-    pp_node = sdocWithDynFlags $ \dflags -> case node of-      -- label:-      CmmEntry id tscope -> lbl <> colon <+>-         (sdocWithDynFlags $ \dflags ->-           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))-          where-            lbl = if gopt Opt_SuppressUniques dflags-                then text "_lbl_"-                else ppr id--      -- // text-      CmmComment s -> text "//" <+> ftext s--      -- //tick bla<...>-      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $-                   text "//tick" <+> ppr t--      -- unwind reg = expr;-      CmmUnwind regs ->-          text "unwind "-          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi--      -- reg = expr;-      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi--      -- rep[lv] = expr;-      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi-          where-            rep = sdocWithDynFlags $ \dflags ->-                  ppr ( cmmExprType dflags expr )--      -- call "ccall" foo(x, y)[r1, r2];-      -- ToDo ppr volatile-      CmmUnsafeForeignCall target results args ->-          hsep [ ppUnless (null results) $-                    parens (commafy $ map ppr results) <+> equals,-                 text "call",-                 ppr target <> parens (commafy $ map ppr args) <> semi]--      -- goto label;-      CmmBranch ident -> text "goto" <+> ppr ident <> semi--      -- if (expr) goto t; else goto f;-      CmmCondBranch expr t f l ->-          hsep [ text "if"-               , parens(ppr expr)-               , case l of-                   Nothing -> empty-                   Just b -> parens (text "likely:" <+> ppr b)-               , text "goto"-               , ppr t <> semi-               , text "else goto"-               , ppr f <> semi-               ]--      CmmSwitch expr ids ->-          hang (hsep [ text "switch"-                     , range-                     , if isTrivialCmmExpr expr-                       then ppr expr-                       else parens (ppr expr)-                     , text "{"-                     ])-             4 (vcat (map ppCase cases) $$ def) $$ rbrace-          where-            (cases, mbdef) = switchTargetsFallThrough ids-            ppCase (is,l) = hsep-                            [ text "case"-                            , commafy $ map integer is-                            , text ": goto"-                            , ppr l <> semi-                            ]-            def | Just l <- mbdef = hsep-                            [ text "default:"-                            , braces (text "goto" <+> ppr l <> semi)-                            ]-                | otherwise = empty--            range = brackets $ hsep [integer lo, text "..", integer hi]-              where (lo,hi) = switchTargetsRange ids--      CmmCall tgt k regs out res updfr_off ->-          hcat [ text "call", space-               , pprFun tgt, parens (interpp'SP regs), space-               , returns <+>-                 text "args: " <> ppr out <> comma <+>-                 text "res: " <> ppr res <> comma <+>-                 text "upd: " <> ppr updfr_off-               , semi ]-          where pprFun f@(CmmLit _) = ppr f-                pprFun f = parens (ppr f)--                returns-                  | Just r <- k = text "returns to" <+> ppr r <> comma-                  | otherwise   = empty--      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->-          hcat $ if i then [text "interruptible", space] else [] ++-               [ text "foreign call", space-               , ppr t, text "(...)", space-               , text "returns to" <+> ppr s-                    <+> text "args:" <+> parens (ppr as)-                    <+> text "ress:" <+> parens (ppr rs)-               , text "ret_args:" <+> ppr a-               , text "ret_off:" <+> ppr u-               , semi ]--    pp_debug :: SDoc-    pp_debug =-      if not debugIsOn then empty-      else case node of-             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"-             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"-             CmmTick {}              -> empty-             CmmUnwind {}            -> text "  // CmmUnwind"-             CmmAssign {}            -> text "  // CmmAssign"-             CmmStore {}             -> text "  // CmmStore"-             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"-             CmmBranch {}            -> text "  // CmmBranch"-             CmmCondBranch {}        -> text "  // CmmCondBranch"-             CmmSwitch {}            -> text "  // CmmSwitch"-             CmmCall {}              -> text "  // CmmCall"-             CmmForeignCall {}       -> text "  // CmmForeignCall"--    commafy :: [SDoc] -> SDoc-    commafy xs = hsep $ punctuate comma xs
− compiler/cmm/PprCmmDecl.hs 
@@ -1,169 +0,0 @@----------------------------------------------------------------------------------- Pretty-printing of common Cmm types------ (c) The University of Glasgow 2004-2006---------------------------------------------------------------------------------------- This is where we walk over Cmm emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:---      1) if a value has wordRep type, the type is not appended in the---      output.---      2) MachOps that operate over wordRep type are printed in a---      C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs-----{-# OPTIONS_GHC -fno-warn-orphans #-}-module PprCmmDecl-    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic-    )-where--import GhcPrelude--import PprCmmExpr-import Cmm--import DynFlags-import Outputable-import FastString--import Data.List-import System.IO--import qualified Data.ByteString as BS---pprCmms :: (Outputable info, Outputable g)-        => [GenCmmGroup CmmStatics info g] -> SDoc-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))-        where-          separator = space $$ text "-------------------" $$ space--writeCmms :: (Outputable info, Outputable g)-          => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()-writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)---------------------------------------------------------------------------------instance (Outputable d, Outputable info, Outputable i)-      => Outputable (GenCmmDecl d info i) where-    ppr t = pprTop t--instance Outputable CmmStatics where-    ppr = pprStatics--instance Outputable CmmStatic where-    ppr = pprStatic--instance Outputable CmmInfoTable where-    ppr = pprInfoTable----------------------------------------------------------------------------------pprCmmGroup :: (Outputable d, Outputable info, Outputable g)-            => GenCmmGroup d info g -> SDoc-pprCmmGroup tops-    = vcat $ intersperse blankLine $ map pprTop tops---- ----------------------------------------------------------------------------- Top level `procedure' blocks.----pprTop :: (Outputable d, Outputable info, Outputable i)-       => GenCmmDecl d info i -> SDoc--pprTop (CmmProc info lbl live graph)--  = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live-         , nest 8 $ lbrace <+> ppr info $$ rbrace-         , nest 4 $ ppr graph-         , rbrace ]---- ----------------------------------------------------------------------------- We follow [1], 4.5------      section "data" { ... }----pprTop (CmmData section ds) =-    (hang (pprSection section <+> lbrace) 4 (ppr ds))-    $$ rbrace---- ----------------------------------------------------------------------------- Info tables.--pprInfoTable :: CmmInfoTable -> SDoc-pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep-                           , cit_prof = prof_info-                           , cit_srt = srt })-  = vcat [ text "label: " <> ppr lbl-         , text "rep: " <> ppr rep-         , case prof_info of-             NoProfilingInfo -> empty-             ProfilingInfo ct cd ->-               vcat [ text "type: " <> text (show (BS.unpack ct))-                    , text "desc: " <> text (show (BS.unpack cd)) ]-         , text "srt: " <> ppr srt ]--instance Outputable ForeignHint where-  ppr NoHint     = empty-  ppr SignedHint = quotes(text "signed")---  ppr AddrHint   = quotes(text "address")--- Temp Jan08-  ppr AddrHint   = (text "PtrHint")---- ----------------------------------------------------------------------------- Static data.---      Strings are printed as C strings, and we print them as I8[],---      following C------pprStatics :: CmmStatics -> SDoc-pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)--pprStatic :: CmmStatic -> SDoc-pprStatic s = case s of-    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi-    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)-    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')---- ----------------------------------------------------------------------------- data sections----pprSection :: Section -> SDoc-pprSection (Section t suffix) =-  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)-  where-    section = text "section"--pprSectionType :: SectionType -> SDoc-pprSectionType s = doubleQuotes (ptext t)- where-  t = case s of-    Text              -> sLit "text"-    Data              -> sLit "data"-    ReadOnlyData      -> sLit "readonly"-    ReadOnlyData16    -> sLit "readonly16"-    RelocatableReadOnlyData-                      -> sLit "relreadonly"-    UninitialisedData -> sLit "uninitialised"-    CString           -> sLit "cstring"-    OtherSection s'   -> sLit s' -- Not actually a literal though.
− compiler/cmm/PprCmmExpr.hs 
@@ -1,286 +0,0 @@----------------------------------------------------------------------------------- Pretty-printing of common Cmm types------ (c) The University of Glasgow 2004-2006---------------------------------------------------------------------------------------- This is where we walk over Cmm emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:---      1) if a value has wordRep type, the type is not appended in the---      output.---      2) MachOps that operate over wordRep type are printed in a---      C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs-----{-# OPTIONS_GHC -fno-warn-orphans #-}-module PprCmmExpr-    ( pprExpr, pprLit-    )-where--import GhcPrelude--import CmmExpr--import Outputable-import DynFlags--import Data.Maybe-import Numeric ( fromRat )---------------------------------------------------------------------------------instance Outputable CmmExpr where-    ppr e = pprExpr e--instance Outputable CmmReg where-    ppr e = pprReg e--instance Outputable CmmLit where-    ppr l = pprLit l--instance Outputable LocalReg where-    ppr e = pprLocalReg e--instance Outputable Area where-    ppr e = pprArea e--instance Outputable GlobalReg where-    ppr e = pprGlobalReg e---- ----------------------------------------------------------------------------- Expressions-----pprExpr :: CmmExpr -> SDoc-pprExpr e-    = sdocWithDynFlags $ \dflags ->-      case e of-        CmmRegOff reg i ->-                pprExpr (CmmMachOp (MO_Add rep)-                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])-                where rep = typeWidth (cmmRegType dflags reg)-        CmmLit lit -> pprLit lit-        _other     -> pprExpr1 e---- Here's the precedence table from CmmParse.y:--- %nonassoc '>=' '>' '<=' '<' '!=' '=='--- %left '|'--- %left '^'--- %left '&'--- %left '>>' '<<'--- %left '-' '+'--- %left '/' '*' '%'--- %right '~'---- We just cope with the common operators for now, the rest will get--- a default conservative behaviour.---- %nonassoc '>=' '>' '<=' '<' '!=' '=='-pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op-   = pprExpr7 x <+> doc <+> pprExpr7 y-pprExpr1 e = pprExpr7 e--infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc--infixMachOp1 (MO_Eq     _) = Just (text "==")-infixMachOp1 (MO_Ne     _) = Just (text "!=")-infixMachOp1 (MO_Shl    _) = Just (text "<<")-infixMachOp1 (MO_U_Shr  _) = Just (text ">>")-infixMachOp1 (MO_U_Ge   _) = Just (text ">=")-infixMachOp1 (MO_U_Le   _) = Just (text "<=")-infixMachOp1 (MO_U_Gt   _) = Just (char '>')-infixMachOp1 (MO_U_Lt   _) = Just (char '<')-infixMachOp1 _             = Nothing---- %left '-' '+'-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0-   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op-   = pprExpr7 x <+> doc <+> pprExpr8 y-pprExpr7 e = pprExpr8 e--infixMachOp7 (MO_Add _)  = Just (char '+')-infixMachOp7 (MO_Sub _)  = Just (char '-')-infixMachOp7 _           = Nothing---- %left '/' '*' '%'-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op-   = pprExpr8 x <+> doc <+> pprExpr9 y-pprExpr8 e = pprExpr9 e--infixMachOp8 (MO_U_Quot _) = Just (char '/')-infixMachOp8 (MO_Mul _)    = Just (char '*')-infixMachOp8 (MO_U_Rem _)  = Just (char '%')-infixMachOp8 _             = Nothing--pprExpr9 :: CmmExpr -> SDoc-pprExpr9 e =-   case e of-        CmmLit    lit       -> pprLit1 lit-        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)-        CmmReg    reg       -> ppr reg-        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)-        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)-        CmmMachOp mop args  -> genMachOp mop args--genMachOp :: MachOp -> [CmmExpr] -> SDoc-genMachOp mop args-   | Just doc <- infixMachOp mop = case args of-        -- dyadic-        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y--        -- unary-        [x]   -> doc <> pprExpr9 x--        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"-                          (pprMachOp mop <+>-                            parens (hcat $ punctuate comma (map pprExpr args)))-                          empty--   | isJust (infixMachOp1 mop)-   || isJust (infixMachOp7 mop)-   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))--   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))-        where ppr_op = text (map (\c -> if c == ' ' then '_' else c)-                                 (show mop))-                -- replace spaces in (show mop) with underscores,------- Unsigned ops on the word size of the machine get nice symbols.--- All else get dumped in their ugly format.----infixMachOp :: MachOp -> Maybe SDoc-infixMachOp mop-        = case mop of-            MO_And    _ -> Just $ char '&'-            MO_Or     _ -> Just $ char '|'-            MO_Xor    _ -> Just $ char '^'-            MO_Not    _ -> Just $ char '~'-            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)-            _ -> Nothing---- ----------------------------------------------------------------------------- Literals.---  To minimise line noise we adopt the convention that if the literal---  has the natural machine word size, we do not append the type----pprLit :: CmmLit -> SDoc-pprLit lit = sdocWithDynFlags $ \dflags ->-             case lit of-    CmmInt i rep ->-        hcat [ (if i < 0 then parens else id)(integer i)-             , ppUnless (rep == wordWidth dflags) $-               space <> dcolon <+> ppr rep ]--    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]-    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'-    CmmLabel clbl      -> ppr clbl-    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i-    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'-                                  <> ppr clbl2 <> ppr_offset i-    CmmBlock id        -> ppr id-    CmmHighStackMark -> text "<highSp>"--pprLit1 :: CmmLit -> SDoc-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)-pprLit1 lit                  = pprLit lit--ppr_offset :: Int -> SDoc-ppr_offset i-    | i==0      = empty-    | i>=0      = char '+' <> int i-    | otherwise = char '-' <> int (-i)---- ----------------------------------------------------------------------------- Registers, whether local (temps) or global----pprReg :: CmmReg -> SDoc-pprReg r-    = case r of-        CmmLocal  local  -> pprLocalReg  local-        CmmGlobal global -> pprGlobalReg global------- We only print the type of the local reg if it isn't wordRep----pprLocalReg :: LocalReg -> SDoc-pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->---   = ppr rep <> char '_' <> ppr uniq--- Temp Jan08-    char '_' <> pprUnique dflags uniq <>-       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh-                    then dcolon <> ptr <> ppr rep-                    else dcolon <> ptr <> ppr rep)-   where-     pprUnique dflags unique =-        if gopt Opt_SuppressUniques dflags-            then text "_locVar_"-            else ppr unique-     ptr = empty-         --if isGcPtrType rep-         --      then doubleQuotes (text "ptr")-         --      else empty---- Stack areas-pprArea :: Area -> SDoc-pprArea Old        = text "old"-pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]---- needs to be kept in syn with CmmExpr.hs.GlobalReg----pprGlobalReg :: GlobalReg -> SDoc-pprGlobalReg gr-    = case gr of-        VanillaReg n _ -> char 'R' <> int n--- Temp Jan08---        VanillaReg n VNonGcPtr -> char 'R' <> int n---        VanillaReg n VGcPtr    -> char 'P' <> int n-        FloatReg   n   -> char 'F' <> int n-        DoubleReg  n   -> char 'D' <> int n-        LongReg    n   -> char 'L' <> int n-        XmmReg     n   -> text "XMM" <> int n-        YmmReg     n   -> text "YMM" <> int n-        ZmmReg     n   -> text "ZMM" <> int n-        Sp             -> text "Sp"-        SpLim          -> text "SpLim"-        Hp             -> text "Hp"-        HpLim          -> text "HpLim"-        MachSp         -> text "MachSp"-        UnwindReturnReg-> text "UnwindReturnReg"-        CCCS           -> text "CCCS"-        CurrentTSO     -> text "CurrentTSO"-        CurrentNursery -> text "CurrentNursery"-        HpAlloc        -> text "HpAlloc"-        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"-        GCEnter1       -> text "stg_gc_enter_1"-        GCFun          -> text "stg_gc_fun"-        BaseReg        -> text "BaseReg"-        PicBaseReg     -> text "PicBaseReg"---------------------------------------------------------------------------------commafy :: [SDoc] -> SDoc-commafy xs = fsep $ punctuate comma xs
− compiler/cmm/SMRep.hs 
@@ -1,563 +0,0 @@--- (c) The University of Glasgow 2006--- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998------ Storage manager representation of closures--{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}--module SMRep (-        -- * Words and bytes-        WordOff, ByteOff,-        wordsToBytes, bytesToWordsRoundUp,-        roundUpToWords, roundUpTo,--        StgWord, fromStgWord, toStgWord,-        StgHalfWord, fromStgHalfWord, toStgHalfWord,-        halfWordSize, halfWordSizeInBits,--        -- * Closure repesentation-        SMRep(..), -- CmmInfo sees the rep; no one else does-        IsStatic,-        ClosureTypeInfo(..), ArgDescr(..), Liveness,-        ConstrDescription,--        -- ** Construction-        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,-        smallArrPtrsRep, arrWordsRep,--        -- ** Predicates-        isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,-        isStackRep,--        -- ** Size-related things-        heapClosureSizeW,-        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,-        arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,-        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,-        fixedHdrSize,--        -- ** RTS closure types-        rtsClosureType, rET_SMALL, rET_BIG,-        aRG_GEN, aRG_GEN_BIG,--        -- ** Arrays-        card, cardRoundUp, cardTableSizeB, cardTableSizeW-    ) where--import GhcPrelude--import BasicTypes( ConTagZ )-import DynFlags-import Outputable-import GHC.Platform-import FastString--import Data.Word-import Data.Bits-import Data.ByteString (ByteString)--{--************************************************************************-*                                                                      *-                Words and bytes-*                                                                      *-************************************************************************--}---- | Word offset, or word count-type WordOff = Int---- | Byte offset, or byte count-type ByteOff = Int---- | Round up the given byte count to the next byte count that's a--- multiple of the machine's word size.-roundUpToWords :: DynFlags -> ByteOff -> ByteOff-roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)---- | Round up @base@ to a multiple of @size@.-roundUpTo :: ByteOff -> ByteOff -> ByteOff-roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))---- | Convert the given number of words to a number of bytes.------ This function morally has type @WordOff -> ByteOff@, but uses @Num--- a@ to allow for overloading.-wordsToBytes :: Num a => DynFlags -> a -> a-wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n-{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}-{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}-{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}---- | First round the given byte count up to a multiple of the--- machine's word size and then convert the result to words.-bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff-bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size- where word_size = wORD_SIZE dflags--- StgWord is a type representing an StgWord on the target platform.--- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform-newtype StgWord = StgWord Word64-    deriving (Eq, Bits)--fromStgWord :: StgWord -> Integer-fromStgWord (StgWord i) = toInteger i--toStgWord :: DynFlags -> Integer -> StgWord-toStgWord dflags i-    = case platformWordSize (targetPlatform dflags) of-      -- These conversions mean that things like toStgWord (-1)-      -- do the right thing-      PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))-      PW8 -> StgWord (fromInteger i)--instance Outputable StgWord where-    ppr (StgWord i) = integer (toInteger i)-------- A Word32 is large enough to hold half a Word for either a 32bit or--- 64bit platform-newtype StgHalfWord = StgHalfWord Word32-    deriving Eq--fromStgHalfWord :: StgHalfWord -> Integer-fromStgHalfWord (StgHalfWord w) = toInteger w--toStgHalfWord :: DynFlags -> Integer -> StgHalfWord-toStgHalfWord dflags i-    = case platformWordSize (targetPlatform dflags) of-      -- These conversions mean that things like toStgHalfWord (-1)-      -- do the right thing-      PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))-      PW8 -> StgHalfWord (fromInteger i :: Word32)--instance Outputable StgHalfWord where-    ppr (StgHalfWord w) = integer (toInteger w)---- | Half word size in bytes-halfWordSize :: DynFlags -> ByteOff-halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2--halfWordSizeInBits :: DynFlags -> Int-halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2--{--************************************************************************-*                                                                      *-\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}-*                                                                      *-************************************************************************--}---- | A description of the layout of a closure.  Corresponds directly--- to the closure types in includes/rts/storage/ClosureTypes.h.-data SMRep-  = HeapRep              -- GC routines consult sizes in info tbl-        IsStatic-        !WordOff         --  # ptr words-        !WordOff         --  # non-ptr words INCLUDING SLOP (see mkHeapRep below)-        ClosureTypeInfo  -- type-specific info--  | ArrayPtrsRep-        !WordOff        -- # ptr words-        !WordOff        -- # card table words--  | SmallArrayPtrsRep-        !WordOff        -- # ptr words--  | ArrayWordsRep-        !WordOff        -- # bytes expressed in words, rounded up--  | StackRep            -- Stack frame (RET_SMALL or RET_BIG)-        Liveness--  | RTSRep              -- The RTS needs to declare info tables with specific-        Int             -- type tags, so this form lets us override the default-        SMRep           -- tag for an SMRep.---- | True <=> This is a static closure.  Affects how we garbage-collect it.--- Static closure have an extra static link field at the end.--- Constructors do not have a static variant; see Note [static constructors]-type IsStatic = Bool---- From an SMRep you can get to the closure type defined in--- includes/rts/storage/ClosureTypes.h. Described by the function--- rtsClosureType below.--data ClosureTypeInfo-  = Constr        ConTagZ ConstrDescription-  | Fun           FunArity ArgDescr-  | Thunk-  | ThunkSelector SelectorOffset-  | BlackHole-  | IndStatic--type ConstrDescription = ByteString -- result of dataConIdentity-type FunArity          = Int-type SelectorOffset    = Int------------------------------ We represent liveness bitmaps as a Bitmap (whose internal--- representation really is a bitmap).  These are pinned onto case return--- vectors to indicate the state of the stack for the garbage collector.------ In the compiled program, liveness bitmaps that fit inside a single--- word (StgWord) are stored as a single word, while larger bitmaps are--- stored as a pointer to an array of words.--type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead-                         --                    False <=> ptr------------------------------ An ArgDescr describes the argument pattern of a function--data ArgDescr-  = ArgSpec             -- Fits one of the standard patterns-        !Int            -- RTS type identifier ARG_P, ARG_N, ...--  | ArgGen              -- General case-        Liveness        -- Details about the arguments----------------------------------------------------------------------------------- Construction--mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo-          -> SMRep-mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info-  = HeapRep is_static-            ptr_wds-            (nonptr_wds + slop_wds)-            cl_type_info-  where-     slop_wds-      | is_static = 0-      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))--     hdr_size     = closureTypeHdrSize dflags cl_type_info-     payload_size = ptr_wds + nonptr_wds--mkRTSRep :: Int -> SMRep -> SMRep-mkRTSRep = RTSRep--mkStackRep :: [Bool] -> SMRep-mkStackRep liveness = StackRep liveness--blackHoleRep :: SMRep-blackHoleRep = HeapRep False 0 0 BlackHole--indStaticRep :: SMRep-indStaticRep = HeapRep True 1 0 IndStatic--arrPtrsRep :: DynFlags -> WordOff -> SMRep-arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)--smallArrPtrsRep :: WordOff -> SMRep-smallArrPtrsRep elems = SmallArrayPtrsRep elems--arrWordsRep :: DynFlags -> ByteOff -> SMRep-arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)---------------------------------------------------------------------------------- Predicates--isStaticRep :: SMRep -> IsStatic-isStaticRep (HeapRep is_static _ _ _) = is_static-isStaticRep (RTSRep _ rep)            = isStaticRep rep-isStaticRep _                         = False--isStackRep :: SMRep -> Bool-isStackRep StackRep{}     = True-isStackRep (RTSRep _ rep) = isStackRep rep-isStackRep _              = False--isConRep :: SMRep -> Bool-isConRep (HeapRep _ _ _ Constr{}) = True-isConRep _                        = False--isThunkRep :: SMRep -> Bool-isThunkRep (HeapRep _ _ _ Thunk)           = True-isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True-isThunkRep (HeapRep _ _ _ BlackHole)       = True-isThunkRep (HeapRep _ _ _ IndStatic)       = True-isThunkRep _                               = False--isFunRep :: SMRep -> Bool-isFunRep (HeapRep _ _ _ Fun{}) = True-isFunRep _                     = False--isStaticNoCafCon :: SMRep -> Bool--- This should line up exactly with CONSTR_NOCAF below--- See Note [Static NoCaf constructors]-isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True-isStaticNoCafCon _                        = False----------------------------------------------------------------------------------- Size-related things--fixedHdrSize :: DynFlags -> ByteOff-fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)---- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)-fixedHdrSizeW :: DynFlags -> WordOff-fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags---- | Size of the profiling part of a closure header--- (StgProfHeader in includes/rts/storage/Closures.h)-profHdrSize  :: DynFlags -> WordOff-profHdrSize dflags- | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags- | otherwise                      = 0---- | The garbage collector requires that every closure is at least as---   big as this.-minClosureSize :: DynFlags -> WordOff-minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags--arrWordsHdrSize :: DynFlags -> ByteOff-arrWordsHdrSize dflags- = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags--arrWordsHdrSizeW :: DynFlags -> WordOff-arrWordsHdrSizeW dflags =-    fixedHdrSizeW dflags +-    (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)--arrPtrsHdrSize :: DynFlags -> ByteOff-arrPtrsHdrSize dflags- = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags--arrPtrsHdrSizeW :: DynFlags -> WordOff-arrPtrsHdrSizeW dflags =-    fixedHdrSizeW dflags +-    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)--smallArrPtrsHdrSize :: DynFlags -> ByteOff-smallArrPtrsHdrSize dflags- = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags--smallArrPtrsHdrSizeW :: DynFlags -> WordOff-smallArrPtrsHdrSizeW dflags =-    fixedHdrSizeW dflags +-    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)---- Thunks have an extra header word on SMP, so the update doesn't--- splat the payload.-thunkHdrSize :: DynFlags -> WordOff-thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr-        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags--hdrSize :: DynFlags -> SMRep -> ByteOff-hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)--hdrSizeW :: DynFlags -> SMRep -> WordOff-hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty-hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags-hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags-hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags-hdrSizeW _ _                          = panic "SMRep.hdrSizeW"--nonHdrSize :: DynFlags -> SMRep -> ByteOff-nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)--nonHdrSizeW :: SMRep -> WordOff-nonHdrSizeW (HeapRep _ p np _) = p + np-nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct-nonHdrSizeW (SmallArrayPtrsRep elems) = elems-nonHdrSizeW (ArrayWordsRep words) = words-nonHdrSizeW (StackRep bs)      = length bs-nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep---- | The total size of the closure, in words.-heapClosureSizeW :: DynFlags -> SMRep -> WordOff-heapClosureSizeW dflags (HeapRep _ p np ty)- = closureTypeHdrSize dflags ty + p + np-heapClosureSizeW dflags (ArrayPtrsRep elems ct)- = arrPtrsHdrSizeW dflags + elems + ct-heapClosureSizeW dflags (SmallArrayPtrsRep elems)- = smallArrPtrsHdrSizeW dflags + elems-heapClosureSizeW dflags (ArrayWordsRep words)- = arrWordsHdrSizeW dflags + words-heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"--closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff-closureTypeHdrSize dflags ty = case ty of-                  Thunk           -> thunkHdrSize dflags-                  ThunkSelector{} -> thunkHdrSize dflags-                  BlackHole       -> thunkHdrSize dflags-                  IndStatic       -> thunkHdrSize dflags-                  _               -> fixedHdrSizeW dflags-        -- All thunks use thunkHdrSize, even if they are non-updatable.-        -- this is because we don't have separate closure types for-        -- updatable vs. non-updatable thunks, so the GC can't tell the-        -- difference.  If we ever have significant numbers of non--        -- updatable thunks, it might be worth fixing this.---- ------------------------------------------------------------------------------ Arrays---- | The byte offset into the card table of the card for a given element-card :: DynFlags -> Int -> Int-card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags---- | Convert a number of elements to a number of cards, rounding up-cardRoundUp :: DynFlags -> Int -> Int-cardRoundUp dflags i =-  card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))---- | The size of a card table, in bytes-cardTableSizeB :: DynFlags -> Int -> ByteOff-cardTableSizeB dflags elems = cardRoundUp dflags elems---- | The size of a card table, in words-cardTableSizeW :: DynFlags -> Int -> WordOff-cardTableSizeW dflags elems =-  bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)---------------------------------------------------------------------------------- deriving the RTS closure type from an SMRep--#include "rts/storage/ClosureTypes.h"-#include "rts/storage/FunTypes.h"--- Defines CONSTR, CONSTR_1_0 etc---- | Derives the RTS closure type from an 'SMRep'-rtsClosureType :: SMRep -> Int-rtsClosureType rep-    = case rep of-      RTSRep ty _ -> ty--      -- See Note [static constructors]-      HeapRep _     1 0 Constr{} -> CONSTR_1_0-      HeapRep _     0 1 Constr{} -> CONSTR_0_1-      HeapRep _     2 0 Constr{} -> CONSTR_2_0-      HeapRep _     1 1 Constr{} -> CONSTR_1_1-      HeapRep _     0 2 Constr{} -> CONSTR_0_2-      HeapRep _     0 _ Constr{} -> CONSTR_NOCAF-           -- See Note [Static NoCaf constructors]-      HeapRep _     _ _ Constr{} -> CONSTR--      HeapRep False 1 0 Fun{} -> FUN_1_0-      HeapRep False 0 1 Fun{} -> FUN_0_1-      HeapRep False 2 0 Fun{} -> FUN_2_0-      HeapRep False 1 1 Fun{} -> FUN_1_1-      HeapRep False 0 2 Fun{} -> FUN_0_2-      HeapRep False _ _ Fun{} -> FUN--      HeapRep False 1 0 Thunk -> THUNK_1_0-      HeapRep False 0 1 Thunk -> THUNK_0_1-      HeapRep False 2 0 Thunk -> THUNK_2_0-      HeapRep False 1 1 Thunk -> THUNK_1_1-      HeapRep False 0 2 Thunk -> THUNK_0_2-      HeapRep False _ _ Thunk -> THUNK--      HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR--      HeapRep True _ _ Fun{}      -> FUN_STATIC-      HeapRep True _ _ Thunk      -> THUNK_STATIC-      HeapRep False _ _ BlackHole -> BLACKHOLE-      HeapRep False _ _ IndStatic -> IND_STATIC--      _ -> panic "rtsClosureType"---- We export these ones-rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int-rET_SMALL   = RET_SMALL-rET_BIG     = RET_BIG-aRG_GEN     = ARG_GEN-aRG_GEN_BIG = ARG_GEN_BIG--{--Note [static constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~--We used to have a CONSTR_STATIC closure type, and each constructor had-two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with-CONSTR_STATIC.--This distinction was removed, because when copying a data structure-into a compact region, we must copy static constructors into the-compact region too.  If we didn't do this, we would need to track the-references from the compact region out to the static constructors,-because they might (indirectly) refer to CAFs.--Since static constructors will be copied to the heap, if we wanted to-use different info tables for static and dynamic constructors, we-would have to switch the info pointer when copying the constructor-into the compact region, which means we would need an extra field of-the static info table to point to the dynamic one.--However, since the distinction between static and dynamic closure-types is never actually needed (other than for assertions), we can-just drop the distinction and use the same info table for both.--The GC *does* need to distinguish between static and dynamic closures,-but it does this using the HEAP_ALLOCED() macro which checks whether-the address of the closure resides within the dynamic heap.-HEAP_ALLOCED() doesn't read the closure's info table.--Note [Static NoCaf constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we know that a top-level binding 'x' is not Caffy (ie no CAFs are-reachable from 'x'), then a statically allocated constructor (Just x)-is also not Caffy, and the garbage collector need not follow its-argument fields.  Exploiting this would require two static info tables-for Just, for the two cases where the argument was Caffy or non-Caffy.--Currently we don't do this; instead we treat nullary constructors-as non-Caffy, and the others as potentially Caffy.---************************************************************************-*                                                                      *-             Pretty printing of SMRep and friends-*                                                                      *-************************************************************************--}--instance Outputable ClosureTypeInfo where-   ppr = pprTypeInfo--instance Outputable SMRep where-   ppr (HeapRep static ps nps tyinfo)-     = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace)-     where-       header = text "HeapRep"-                <+> if static then text "static" else empty-                <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps-       pp_n :: String -> Int -> SDoc-       pp_n _ 0 = empty-       pp_n s n = int n <+> text s--   ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size--   ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size--   ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words--   ppr (StackRep bs) = text "StackRep" <+> ppr bs--   ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep--instance Outputable ArgDescr where-  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n-  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls--pprTypeInfo :: ClosureTypeInfo -> SDoc-pprTypeInfo (Constr tag descr)-  = text "Con" <+>-    braces (sep [ text "tag:" <+> ppr tag-                , text "descr:" <> text (show descr) ])--pprTypeInfo (Fun arity args)-  = text "Fun" <+>-    braces (sep [ text "arity:" <+> ppr arity-                , ptext (sLit ("fun_type:")) <+> ppr args ])--pprTypeInfo (ThunkSelector offset)-  = text "ThunkSel" <+> ppr offset--pprTypeInfo Thunk     = text "Thunk"-pprTypeInfo BlackHole = text "BlackHole"-pprTypeInfo IndStatic = text "IndStatic"
compiler/coreSyn/CoreLint.hs view
@@ -166,7 +166,7 @@  However, when linting <body> we need to remember that a=Int, else we might reject a correct program.  So we carry a type substitution (in this example-[a -> Int]) and apply this substitution before comparing types.  The functin+[a -> Int]) and apply this substitution before comparing types.  The function         lintInTy :: Type -> LintM (Type, Kind) returns a substituted type. @@ -489,7 +489,7 @@  We do not need to call lintUnfolding on unfoldings that are nested within top-level unfoldings; they are linted when we lint the top-level unfolding;-hence the `TopLevelFlag` on `tcPragExpr` in TcIface.+hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.  -}
compiler/deSugar/Coverage.hs view
@@ -8,6 +8,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module Coverage (addTicksToBinds, hpcInitCode) where  import GhcPrelude as Prelude@@ -41,7 +43,7 @@ import BasicTypes import MonadUtils import Maybes-import CLabel+import GHC.Cmm.CLabel import Util  import Data.Time@@ -1195,7 +1197,7 @@   let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs           -- unlifted types cause two problems here:           --   * we can't bind them  at the GHCi prompt-          --     (bindLocalsAtBreakpoint already fliters them out),+          --     (bindLocalsAtBreakpoint already filters them out),           --   * the simplifier might try to substitute a literal for           --     the Id, and we can't handle that.
compiler/deSugar/Desugar.hs view
@@ -516,7 +516,7 @@   {-# RULES "rule-for-f" forall x. f (g x) = ... #-} then there's a good chance that in a potential rule redex     ...f (g e)...-then 'f' or 'g' will inline befor the rule can fire.  Solution: add an+then 'f' or 'g' will inline before the rule can fire.  Solution: add an INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.  Note that this applies to all the free variables on the LHS, both the
compiler/deSugar/DsArrows.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module DsArrows ( dsProcExpr ) where  #include "HsVersions.h"
compiler/deSugar/DsBinds.hs view
@@ -15,6 +15,8 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,                  dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule   ) where@@ -367,7 +369,7 @@ -- -- Other decisions about whether to inline are made in -- `calcUnfoldingGuidance` but the decision about whether to then expose--- the unfolding in the interface file is made in `TidyPgm.addExternal`+-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` -- using this information. ------------------------ makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr@@ -792,7 +794,7 @@ We need two pragma-like things:  * spec_fn's inline pragma: inherited from f's inline pragma (ignoring-                           activation on SPEC), unless overriden by SPEC INLINE+                           activation on SPEC), unless overridden by SPEC INLINE  * Activation of RULE: from SPECIALISE pragma (if activation given)                       otherwise from f's inline pragma
compiler/deSugar/DsCCall.hs view
@@ -7,6 +7,8 @@ -}  {-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module DsCCall         ( dsCCall         , mkFCall
compiler/deSugar/DsExpr.hs view
@@ -10,6 +10,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds               , dsValBinds, dsLit, dsSyntaxExpr               , dsHandleMonadicFailure ) where@@ -709,7 +712,7 @@ -- Template Haskell stuff  ds_expr _ (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"-ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps+ds_expr _ (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps ds_expr _ (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)  -- Arrow notation extension@@ -1075,7 +1078,7 @@                          _ -> return () } } }    | otherwise   -- RHS does have type of form (m ty), which is weird-  = return ()   -- but at lesat this warning is irrelevant+  = return ()   -- but at least this warning is irrelevant  badMonadBind :: LHsExpr GhcTc -> Type -> SDoc badMonadBind rhs elt_ty
compiler/deSugar/DsForeign.hs view
@@ -11,6 +11,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module DsForeign ( dsForeigns ) where  #include "HsVersions.h"@@ -37,8 +39,8 @@ import TcEnv import TcType -import CmmExpr-import CmmUtils+import GHC.Cmm.Expr+import GHC.Cmm.Utils import HscTypes import ForeignCall import TysWiredIn
compiler/deSugar/DsListComp.hs view
@@ -380,7 +380,7 @@     b <- newSysLocalDs b_ty     x <- newSysLocalDs x_ty -    -- build rest of the comprehesion+    -- build rest of the comprehension     core_rest <- dfListComp c_id b quals      -- build the pattern match
compiler/deSugar/DsMeta.hs view
@@ -1,2753 +1,2957 @@ {-# LANGUAGE CPP, TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}------------------------------------------------------------------------------------- (c) The University of Glasgow 2006------ The purpose of this module is to transform an HsExpr into a CoreExpr which--- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the--- input HsExpr. We do this in the DsM monad, which supplies access to--- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.------ It also defines a bunch of knownKeyNames, in the same way as is done--- in prelude/PrelNames.  It's much more convenient to do it here, because--- otherwise we have to recompile PrelNames whenever we add a Name, which is--- a Royal Pain (triggers other recompilation).--------------------------------------------------------------------------------module DsMeta( dsBracket ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-}   DsExpr ( dsExpr )--import MatchLit-import DsMonad--import qualified Language.Haskell.TH as TH--import GHC.Hs-import PrelNames--- To avoid clashes with DsMeta.varName we must make a local alias for--- OccName.varName we do this by removing varName from the import of--- OccName above, making a qualified instance of OccName and using--- OccNameAlias.varName where varName ws previously used in this file.-import qualified OccName( isDataOcc, isVarOcc, isTcOcc )--import Module-import Id-import Name hiding( isVarOcc, isTcOcc, varName, tcName )-import THNames-import NameEnv-import TcType-import TyCon-import TysWiredIn-import CoreSyn-import MkCore-import CoreUtils-import SrcLoc-import Unique-import BasicTypes-import Outputable-import Bag-import DynFlags-import FastString-import ForeignCall-import Util-import Maybes-import MonadUtils--import Data.ByteString ( unpack )-import Control.Monad-import Data.List--------------------------------------------------------------------------------dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr--- Returns a CoreExpr of type TH.ExpQ--- The quoted thing is parameterised over Name, even though it has--- been type checked.  We don't want all those type decorations!--dsBracket brack splices-  = dsExtendMetaEnv new_bit (do_brack brack)-  where-    new_bit = mkNameEnv [(n, DsSplice (unLoc e))-                        | PendingTcSplice n e <- splices]--    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }-    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }-    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }-    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }-    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }-    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"-    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }-    do_brack (XBracket nec) = noExtCon nec--{- -------------- Examples ----------------------  [| \x -> x |]-====>-  gensym (unpackString "x"#) `bindQ` \ x1::String ->-  lam (pvar x1) (var x1)---  [| \x -> $(f [| x |]) |]-====>-  gensym (unpackString "x"#) `bindQ` \ x1::String ->-  lam (pvar x1) (f (var x1))--}-------------------------------------------------------------                      Declarations----------------------------------------------------------repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)-repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)-                 ; pat' <- addBinds ss (repLP pat)-                 ; wrapGenSyms ss pat' }--repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))-repTopDs group@(HsGroup { hs_valds   = valds-                        , hs_splcds  = splcds-                        , hs_tyclds  = tyclds-                        , hs_derivds = derivds-                        , hs_fixds   = fixds-                        , hs_defds   = defds-                        , hs_fords   = fords-                        , hs_warnds  = warnds-                        , hs_annds   = annds-                        , hs_ruleds  = ruleds-                        , hs_docs    = docs })- = do { let { bndrs  = hsScopedTvBinders valds-                       ++ hsGroupBinders group-                       ++ hsPatSynSelectors valds-            ; instds = tyclds >>= group_instds } ;-        ss <- mkGenSyms bndrs ;--        -- Bind all the names mainly to avoid repeated use of explicit strings.-        -- Thus we get-        --      do { t :: String <- genSym "T" ;-        --           return (Data t [] ...more t's... }-        -- The other important reason is that the output must mention-        -- only "T", not "Foo:T" where Foo is the current module--        decls <- addBinds ss (-                  do { val_ds   <- rep_val_binds valds-                     ; _        <- mapM no_splice splcds-                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)-                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)-                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)-                     ; inst_ds  <- mapM repInstD instds-                     ; deriv_ds <- mapM repStandaloneDerivD derivds-                     ; fix_ds   <- mapM repFixD fixds-                     ; _        <- mapM no_default_decl defds-                     ; for_ds   <- mapM repForD fords-                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)-                                                           warnds)-                     ; ann_ds   <- mapM repAnnD annds-                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)-                                                            ruleds)-                     ; _        <- mapM no_doc docs--                        -- more needed-                     ;  return (de_loc $ sort_by_loc $-                                val_ds ++ catMaybes tycl_ds ++ role_ds-                                       ++ kisig_ds-                                       ++ (concat fix_ds)-                                       ++ inst_ds ++ rule_ds ++ for_ds-                                       ++ ann_ds ++ deriv_ds) }) ;--        decl_ty <- lookupType decQTyConName ;-        let { core_list = coreList' decl_ty decls } ;--        dec_ty <- lookupType decTyConName ;-        q_decs  <- repSequenceQ dec_ty core_list ;--        wrapGenSyms ss q_decs-      }-  where-    no_splice (L loc _)-      = notHandledL loc "Splices within declaration brackets" empty-    no_default_decl (L loc decl)-      = notHandledL loc "Default declarations" (ppr decl)-    no_warn (L loc (Warning _ thing _))-      = notHandledL loc "WARNING and DEPRECATION pragmas" $-                    text "Pragma for declaration of" <+> ppr thing-    no_warn (L _ (XWarnDecl nec)) = noExtCon nec-    no_doc (L loc _)-      = notHandledL loc "Haddock documentation" empty-repTopDs (XHsGroup nec) = noExtCon nec--hsScopedTvBinders :: HsValBinds GhcRn -> [Name]--- See Note [Scoped type variables in bindings]-hsScopedTvBinders binds-  = concatMap get_scoped_tvs sigs-  where-    sigs = case binds of-             ValBinds           _ _ sigs  -> sigs-             XValBindsLR (NValBinds _ sigs) -> sigs--get_scoped_tvs :: LSig GhcRn -> [Name]-get_scoped_tvs (L _ signature)-  | TypeSig _ _ sig <- signature-  = get_scoped_tvs_from_sig (hswc_body sig)-  | ClassOpSig _ _ _ sig <- signature-  = get_scoped_tvs_from_sig sig-  | PatSynSig _ _ sig <- signature-  = get_scoped_tvs_from_sig sig-  | otherwise-  = []-  where-    get_scoped_tvs_from_sig sig-      -- Both implicit and explicit quantified variables-      -- We need the implicit ones for   f :: forall (a::k). blah-      --    here 'k' scopes too-      | HsIB { hsib_ext = implicit_vars-             , hsib_body = hs_ty } <- sig-      , (explicit_vars, _) <- splitLHsForAllTy hs_ty-      = implicit_vars ++ hsLTyVarNames explicit_vars-    get_scoped_tvs_from_sig (XHsImplicitBndrs nec)-      = noExtCon nec--{- Notes--Note [Scoped type variables in bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f :: forall a. a -> a-   f x = x::a-Here the 'forall a' brings 'a' into scope over the binding group.-To achieve this we--  a) Gensym a binding for 'a' at the same time as we do one for 'f'-     collecting the relevant binders with hsScopedTvBinders--  b) When processing the 'forall', don't gensym--The relevant places are signposted with references to this Note--Note [Scoped type variables in class and instance declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Scoped type variables may occur in default methods and default-signatures. We need to bring the type variables in 'foralls'-into the scope of the method bindings.--Consider-   class Foo a where-     foo :: forall (b :: k). a -> Proxy b -> Proxy b-     foo _ x = (x :: Proxy b)--We want to ensure that the 'b' in the type signature and the default-implementation are the same, so we do the following:--  a) Before desugaring the signature and binding of 'foo', use-     get_scoped_tvs to collect type variables in 'forall' and-     create symbols for them.-  b) Use 'addBinds' to bring these symbols into the scope of the type-     signatures and bindings.-  c) Use these symbols to generate Core for the class/instance declaration.--Note that when desugaring the signatures, we lookup the type variables-from the scope rather than recreate symbols for them. See more details-in "rep_ty_sig" and in Trac#14885.--Note [Binders and occurrences]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we desugar [d| data T = MkT |]-we want to get-        Data "T" [] [Con "MkT" []] []-and *not*-        Data "Foo:T" [] [Con "Foo:MkT" []] []-That is, the new data decl should fit into whatever new module it is-asked to fit in.   We do *not* clone, though; no need for this:-        Data "T79" ....--But if we see this:-        data T = MkT-        foo = reifyDecl T--then we must desugar to-        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []--So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.-And we use lookupOcc, rather than lookupBinder-in repTyClD and repC.--Note [Don't quantify implicit type variables in quotes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you're not careful, it's surprisingly easy to take this quoted declaration:--  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b-      idProxy x = x-    |]--and have Template Haskell turn it into this:--  idProxy :: forall k proxy (b :: k). proxy b -> proxy b-  idProxy x = x--Notice that we explicitly quantified the variable `k`! The latter declaration-isn't what the user wrote in the first place.--Usually, the culprit behind these bugs is taking implicitly quantified type-variables (often from the hsib_vars field of HsImplicitBinders) and putting-them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.--}---- represent associated family instances----repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))--repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $-                                              repFamilyDecl (L loc fam)--repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                repSynDecl tc1 bndrs rhs-       ; return (Just (loc, dec)) }--repTyClD (L loc (DataDecl { tcdLName = tc-                          , tcdTyVars = tvs-                          , tcdDataDefn = defn }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                repDataDefn tc1 (Left bndrs) defn-       ; return (Just (loc, dec)) }--repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,-                             tcdTyVars = tvs, tcdFDs = fds,-                             tcdSigs = sigs, tcdMeths = meth_binds,-                             tcdATs = ats, tcdATDefs = atds }))-  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]-       ; dec  <- addTyVarBinds tvs $ \bndrs ->-           do { cxt1   <- repLContext cxt-          -- See Note [Scoped type variables in class and instance declarations]-              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds-              ; fds1   <- repLFunDeps fds-              ; ats1   <- repFamilyDecls ats-              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds-              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)-              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1-              ; wrapGenSyms ss decls2 }-       ; return $ Just (loc, dec)-       }--repTyClD (L _ (XTyClDecl nec)) = noExtCon nec----------------------------repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repRoleD (L loc (RoleAnnotDecl _ tycon roles))-  = do { tycon1 <- lookupLOcc tycon-       ; roles1 <- mapM repRole roles-       ; roles2 <- coreList roleTyConName roles1-       ; dec <- repRoleAnnotD tycon1 roles2-       ; return (loc, dec) }-repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec----------------------------repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repKiSigD (L loc kisig) =-  case kisig of-    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v-    XStandaloneKindSig nec -> noExtCon nec----------------------------repDataDefn :: Core TH.Name-            -> Either (Core [TH.TyVarBndrQ])-                        -- the repTyClD case-                      (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)-                        -- the repDataFamInstD case-            -> HsDataDefn GhcRn-            -> DsM (Core TH.DecQ)-repDataDefn tc opts-          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig-                      , dd_cons = cons, dd_derivs = mb_derivs })-  = do { cxt1     <- repLContext cxt-       ; derivs1  <- repDerivs mb_derivs-       ; case (new_or_data, cons) of-           (NewType, [con])  -> do { con'  <- repC con-                                   ; ksig' <- repMaybeLTy ksig-                                   ; repNewtype cxt1 tc opts ksig' con'-                                                derivs1 }-           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"-                                       <+> pprQuotedList-                                       (getConNames $ unLoc $ head cons))-           (DataType, _) -> do { ksig' <- repMaybeLTy ksig-                               ; consL <- mapM repC cons-                               ; cons1 <- coreList conQTyConName consL-                               ; repData cxt1 tc opts ksig' cons1-                                         derivs1 }-       }-repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec--repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]-           -> LHsType GhcRn-           -> DsM (Core TH.DecQ)-repSynDecl tc bndrs ty-  = do { ty1 <- repLTy ty-       ; repTySyn tc bndrs ty1 }--repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info-                                      , fdLName     = tc-                                      , fdTyVars    = tvs-                                      , fdResultSig = L _ resultSig-                                      , fdInjectivityAnn = injectivity }))-  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]-       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn-             mkHsQTvs tvs = HsQTvs { hsq_ext = []-                                   , hsq_explicit = tvs }-             resTyVar = case resultSig of-                     TyVarSig _ bndr -> mkHsQTvs [bndr]-                     _               -> mkHsQTvs []-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->-                addTyClTyVarBinds resTyVar $ \_ ->-           case info of-             ClosedTypeFamily Nothing ->-                 notHandled "abstract closed type family" (ppr decl)-             ClosedTypeFamily (Just eqns) ->-               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns-                  ; eqns2  <- coreList tySynEqnQTyConName eqns1-                  ; result <- repFamilyResultSig resultSig-                  ; inj    <- repInjectivityAnn injectivity-                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }-             OpenTypeFamily ->-               do { result <- repFamilyResultSig resultSig-                  ; inj    <- repInjectivityAnn injectivity-                  ; repOpenFamilyD tc1 bndrs result inj }-             DataFamily ->-               do { kind <- repFamilyResultSigToMaybeKind resultSig-                  ; repDataFamilyD tc1 bndrs kind }-       ; return (loc, dec)-       }-repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec---- | Represent result signature of a type family-repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)-repFamilyResultSig (NoSig _)         = repNoSig-repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki-                                          ; repKindSig ki' }-repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr-                                          ; repTyVarSig bndr' }-repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec---- | Represent result signature using a Maybe Kind. Used with data families,--- where the result signature can be either missing or a kind but never a named--- result variable.-repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn-                              -> DsM (Core (Maybe TH.KindQ))-repFamilyResultSigToMaybeKind (NoSig _) =-    do { coreNothing kindQTyConName }-repFamilyResultSigToMaybeKind (KindSig _ ki) =-    do { ki' <- repLTy ki-       ; coreJust kindQTyConName ki' }-repFamilyResultSigToMaybeKind TyVarSig{} =-    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"-repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec---- | Represent injectivity annotation of a type family-repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)-                  -> DsM (Core (Maybe TH.InjectivityAnn))-repInjectivityAnn Nothing =-    do { coreNothing injAnnTyConName }-repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =-    do { lhs'   <- lookupBinder (unLoc lhs)-       ; rhs1   <- mapM (lookupBinder . unLoc) rhs-       ; rhs2   <- coreList nameTyConName rhs1-       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]-       ; coreJust injAnnTyConName injAnn }--repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]-repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)--repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)-repAssocTyFamDefaultD = repTyFamInstD------------------------------ represent fundeps----repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])-repLFunDeps fds = repList funDepTyConName repLFunDep fds--repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)-repLFunDep (L _ (xs, ys))-   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs-        ys' <- repList nameTyConName (lookupBinder . unLoc) ys-        repFunDep xs' ys'---- Represent instance declarations----repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))-  = do { dec <- repTyFamInstD fi_decl-       ; return (loc, dec) }-repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))-  = do { dec <- repDataFamInstD fi_decl-       ; return (loc, dec) }-repInstD (L loc (ClsInstD { cid_inst = cls_decl }))-  = do { dec <- repClsInstD cls_decl-       ; return (loc, dec) }-repInstD (L _ (XInstDecl nec)) = noExtCon nec--repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)-repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds-                         , cid_sigs = sigs, cid_tyfam_insts = ats-                         , cid_datafam_insts = adts-                         , cid_overlap_mode = overlap-                         })-  = addSimpleTyVarBinds tvs $-            -- We must bring the type variables into scope, so their-            -- occurrences don't fail, even though the binders don't-            -- appear in the resulting data structure-            ---            -- But we do NOT bring the binders of 'binds' into scope-            -- because they are properly regarded as occurrences-            -- For example, the method names should be bound to-            -- the selector Ids, not to fresh names (#5410)-            ---            do { cxt1     <- repLContext cxt-               ; inst_ty1 <- repLTy inst_ty-          -- See Note [Scoped type variables in class and instance declarations]-               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds-               ; ats1   <- mapM (repTyFamInstD . unLoc) ats-               ; adts1  <- mapM (repDataFamInstD . unLoc) adts-               ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)-               ; rOver  <- repOverlap (fmap unLoc overlap)-               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1-               ; wrapGenSyms ss decls2 }- where-   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty-repClsInstD (XClsInstDecl nec) = noExtCon nec--repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat-                                      , deriv_type     = ty }))-  = do { dec <- addSimpleTyVarBinds tvs $-                do { cxt'     <- repLContext cxt-                   ; strat'   <- repDerivStrategy strat-                   ; inst_ty' <- repLTy inst_ty-                   ; repDeriv strat' cxt' inst_ty' }-       ; return (loc, dec) }-  where-    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)-repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec--repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)-repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })-  = do { eqn1 <- repTyFamEqn eqn-       ; repTySynInst eqn1 }--repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)-repTyFamEqn (HsIB { hsib_ext = var_names-                  , hsib_body = FamEqn { feqn_tycon = tc_name-                                       , feqn_bndrs = mb_bndrs-                                       , feqn_pats = tys-                                       , feqn_fixity = fixity-                                       , feqn_rhs  = rhs }})-  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = var_names-                             , hsq_explicit = fromMaybe [] mb_bndrs }-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName-                                        repTyVarBndr-                                        mb_bndrs-            ; tys1 <- case fixity of-                        Prefix -> repTyArgs (repNamedTyCon tc) tys-                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys-                                     ; t1' <- repLTy t1-                                     ; t2'  <- repLTy t2-                                     ; repTyArgs (repTInfix t1' tc t2') args }-            ; rhs1 <- repLTy rhs-            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }-     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]-           checkTys tys@(HsValArg _:HsValArg _:_) = return tys-           checkTys _ = panic "repTyFamEqn:checkTys"-repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec-repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec--repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)-repTyArgs f [] = f-repTyArgs f (HsValArg ty : as) = do { f' <- f-                                    ; ty' <- repLTy ty-                                    ; repTyArgs (repTapp f' ty') as }-repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f-                                       ; ki' <- repLTy ki-                                       ; repTyArgs (repTappKind f' ki') as }-repTyArgs f (HsArgPar _ : as) = repTyArgs f as--repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)-repDataFamInstD (DataFamInstDecl { dfid_eqn =-                  (HsIB { hsib_ext = var_names-                        , hsib_body = FamEqn { feqn_tycon = tc_name-                                             , feqn_bndrs = mb_bndrs-                                             , feqn_pats  = tys-                                             , feqn_fixity = fixity-                                             , feqn_rhs   = defn }})})-  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = var_names-                             , hsq_explicit = fromMaybe [] mb_bndrs }-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName-                                        repTyVarBndr-                                        mb_bndrs-            ; tys1 <- case fixity of-                        Prefix -> repTyArgs (repNamedTyCon tc) tys-                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys-                                     ; t1' <- repLTy t1-                                     ; t2'  <- repLTy t2-                                     ; repTyArgs (repTInfix t1' tc t2') args }-            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }--      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]-            checkTys tys@(HsValArg _: HsValArg _: _) = return tys-            checkTys _ = panic "repDataFamInstD:checkTys"--repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))-  = noExtCon nec-repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))-  = noExtCon nec--repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)-repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ-                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))- = do MkC name' <- lookupLOcc name-      MkC typ' <- repHsSigType typ-      MkC cc' <- repCCallConv cc-      MkC s' <- repSafety s-      cis' <- conv_cimportspec cis-      MkC str <- coreStringLit (static ++ chStr ++ cis')-      dec <- rep2 forImpDName [cc', s', str, name', typ']-      return (loc, dec)- where-    conv_cimportspec (CLabel cls)-      = notHandled "Foreign label" (doubleQuotes (ppr cls))-    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"-    conv_cimportspec (CFunction (StaticTarget _ fs _ True))-                            = return (unpackFS fs)-    conv_cimportspec (CFunction (StaticTarget _ _  _ False))-                            = panic "conv_cimportspec: values not supported yet"-    conv_cimportspec CWrapper = return "wrapper"-    -- these calling conventions do not support headers and the static keyword-    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv-    static = case cis of-                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "-                 _ -> ""-    chStr = case mch of-            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "-            _ -> ""-repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)-repForD (L _ (XForeignDecl nec)) = noExtCon nec--repCCallConv :: CCallConv -> DsM (Core TH.Callconv)-repCCallConv CCallConv          = rep2 cCallName []-repCCallConv StdCallConv        = rep2 stdCallName []-repCCallConv CApiConv           = rep2 cApiCallName []-repCCallConv PrimCallConv       = rep2 primCallName []-repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []--repSafety :: Safety -> DsM (Core TH.Safety)-repSafety PlayRisky = rep2 unsafeName []-repSafety PlayInterruptible = rep2 interruptibleName []-repSafety PlaySafe = rep2 safeName []--repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]-repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))-  = do { MkC prec' <- coreIntLit prec-       ; let rep_fn = case dir of-                        InfixL -> infixLDName-                        InfixR -> infixRDName-                        InfixN -> infixNDName-       ; let do_one name-              = do { MkC name' <- lookupLOcc name-                   ; dec <- rep2 rep_fn [prec', name']-                   ; return (loc,dec) }-       ; mapM do_one names }-repFixD (L _ (XFixitySig nec)) = noExtCon nec--repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repRuleD (L loc (HsRule { rd_name = n-                        , rd_act = act-                        , rd_tyvs = ty_bndrs-                        , rd_tmvs = tm_bndrs-                        , rd_lhs = lhs-                        , rd_rhs = rhs }))-  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->-         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs-            ; ss <- mkGenSyms tm_bndr_names-            ; rule <- addBinds ss $-                      do { ty_bndrs' <- case ty_bndrs of-                             Nothing -> coreNothingList tyVarBndrQTyConName-                             Just _  -> coreJustList tyVarBndrQTyConName-                                          ex_bndrs-                         ; tm_bndrs' <- repList ruleBndrQTyConName-                                                repRuleBndr-                                                tm_bndrs-                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n-                         ; act' <- repPhases act-                         ; lhs' <- repLE lhs-                         ; rhs' <- repLE rhs-                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }-           ; wrapGenSyms ss rule  }-       ; return (loc, rule) }-repRuleD (L _ (XRuleDecl nec)) = noExtCon nec--ruleBndrNames :: LRuleBndr GhcRn -> [Name]-ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]-ruleBndrNames (L _ (RuleBndrSig _ n sig))-  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig-  = unLoc n : vars-ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))-  = noExtCon nec-ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))-  = noExtCon nec-ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec--repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)-repRuleBndr (L _ (RuleBndr _ n))-  = do { MkC n' <- lookupLBinder n-       ; rep2 ruleVarName [n'] }-repRuleBndr (L _ (RuleBndrSig _ n sig))-  = do { MkC n'  <- lookupLBinder n-       ; MkC ty' <- repLTy (hsSigWcType sig)-       ; rep2 typedRuleVarName [n', ty'] }-repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec--repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))-  = do { target <- repAnnProv ann_prov-       ; exp'   <- repE exp-       ; dec    <- repPragAnn target exp'-       ; return (loc, dec) }-repAnnD (L _ (XAnnDecl nec)) = noExtCon nec--repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)-repAnnProv (ValueAnnProvenance (L _ n))-  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level-       ; rep2 valueAnnotationName [ n' ] }-repAnnProv (TypeAnnProvenance (L _ n))-  = do { MkC n' <- globalVar n-       ; rep2 typeAnnotationName [ n' ] }-repAnnProv ModuleAnnProvenance-  = rep2 moduleAnnotationName []------------------------------------------------------------                      Constructors----------------------------------------------------------repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)-repC (L _ (ConDeclH98 { con_name   = con-                      , con_forall = L _ False-                      , con_mb_cxt = Nothing-                      , con_args   = args }))-  = repDataCon con args--repC (L _ (ConDeclH98 { con_name = con-                      , con_forall = L _ is_existential-                      , con_ex_tvs = con_tvs-                      , con_mb_cxt = mcxt-                      , con_args = args }))-  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->-         do { c'    <- repDataCon con args-            ; ctxt' <- repMbContext mcxt-            ; if not is_existential && isNothing mcxt-              then return c'-              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])-            }-       }--repC (L _ (ConDeclGADT { con_names  = cons-                       , con_qvars  = qtvs-                       , con_mb_cxt = mcxt-                       , con_args   = args-                       , con_res_ty = res_ty }))-  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables-  , Nothing <- mcxt      -- No context-                         -- ==> no need for a forall-  = repGadtDataCons cons args res_ty--  | otherwise-  = addTyVarBinds qtvs $ \ ex_bndrs ->-             -- See Note [Don't quantify implicit type variables in quotes]-    do { c'    <- repGadtDataCons cons args res_ty-       ; ctxt' <- repMbContext mcxt-       ; if null (hsQTvExplicit qtvs) && isNothing mcxt-         then return c'-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }--repC (L _ (XConDecl nec)) = noExtCon nec---repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)-repMbContext Nothing          = repContext []-repMbContext (Just (L _ cxt)) = repContext cxt--repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)-repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []-repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []-repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []--repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)-repSrcStrictness SrcLazy     = rep2 sourceLazyName         []-repSrcStrictness SrcStrict   = rep2 sourceStrictName       []-repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []--repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))-repBangTy ty = do-  MkC u <- repSrcUnpackedness su'-  MkC s <- repSrcStrictness ss'-  MkC b <- rep2 bangName [u, s]-  MkC t <- repLTy ty'-  rep2 bangTypeName [b, t]-  where-    (su', ss', ty') = case unLoc ty of-            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)-            _ -> (NoSrcUnpack, NoSrcStrict, ty)------------------------------------------------------------                      Deriving clauses----------------------------------------------------------repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])-repDerivs (L _ clauses)-  = repList derivClauseQTyConName repDerivClause clauses--repDerivClause :: LHsDerivingClause GhcRn-               -> DsM (Core TH.DerivClauseQ)-repDerivClause (L _ (HsDerivingClause-                          { deriv_clause_strategy = dcs-                          , deriv_clause_tys      = L _ dct }))-  = do MkC dcs' <- repDerivStrategy dcs-       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct-       rep2 derivClauseName [dcs',dct']-  where-    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)-    rep_deriv_ty ty = repLTy ty-repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec--rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn-               -> DsM ([GenSymBind], [Core TH.DecQ])--- Represent signatures and methods in class/instance declarations.--- See Note [Scoped type variables in class and instance declarations]------ Why not use 'repBinds': we have already created symbols for methods in--- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate--- these fun_id via 'collectHsValBinders decs', which would lead to the--- instance declarations failing in TH.-rep_sigs_binds sigs binds-  = do { let tvs = concatMap get_scoped_tvs sigs-       ; ss <- mkGenSyms tvs-       ; sigs1 <- addBinds ss $ rep_sigs sigs-       ; binds1 <- addBinds ss $ rep_binds binds-       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }------------------------------------------------------------   Signatures in a class decl, or a group of bindings----------------------------------------------------------rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]-        -- We silently ignore ones we don't recognise-rep_sigs = concatMapM rep_sig--rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]-rep_sig (L loc (TypeSig _ nms ty))-  = mapM (rep_wc_ty_sig sigDName loc ty) nms-rep_sig (L loc (PatSynSig _ nms ty))-  = mapM (rep_patsyn_ty_sig loc ty) nms-rep_sig (L loc (ClassOpSig _ is_deflt nms ty))-  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms-  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms-rep_sig d@(L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)-rep_sig (L _   (FixSig {}))          = return [] -- fixity sigs at top level-rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc-rep_sig (L loc (SpecSig _ nm tys ispec))-  = concatMapM (\t -> rep_specialise nm t ispec loc) tys-rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc-rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty-rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty-rep_sig (L loc (CompleteMatchSig _ _st cls mty))-  = rep_complete_sig cls mty loc-rep_sig (L _ (XSig nec)) = noExtCon nec--rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name-           -> DsM (SrcSpan, Core TH.DecQ)--- Don't create the implicit and explicit variables when desugaring signatures,--- see Note [Scoped type variables in class and instance declarations].--- and Note [Don't quantify implicit type variables in quotes]-rep_ty_sig mk_sig loc sig_ty nm-  | HsIB { hsib_body = hs_ty } <- sig_ty-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty-  = do { nm1 <- lookupLOcc nm-       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)-                                     ; repTyVarBndrWithKind tv name }-       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv-                                    explicit_tvs--         -- NB: Don't pass any implicit type variables to repList above-         -- See Note [Don't quantify implicit type variables in quotes]--       ; th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)-                       then return th_ty-                       else repTForall th_explicit_tvs th_ctxt th_ty-       ; sig     <- repProto mk_sig nm1 ty1-       ; return (loc, sig) }-rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec--rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name-                  -> DsM (SrcSpan, Core TH.DecQ)--- represents a pattern synonym type signature;--- see Note [Pattern synonym type signatures and Template Haskell] in Convert------ Don't create the implicit and explicit variables when desugaring signatures,--- see Note [Scoped type variables in class and instance declarations]--- and Note [Don't quantify implicit type variables in quotes]-rep_patsyn_ty_sig loc sig_ty nm-  | HsIB { hsib_body = hs_ty } <- sig_ty-  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty-  = do { nm1 <- lookupLOcc nm-       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)-                                     ; repTyVarBndrWithKind tv name }-       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs-       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis--         -- NB: Don't pass any implicit type variables to repList above-         -- See Note [Don't quantify implicit type variables in quotes]--       ; th_reqs  <- repLContext reqs-       ; th_provs <- repLContext provs-       ; th_ty    <- repLTy ty-       ; ty1      <- repTForall th_univs th_reqs =<<-                       repTForall th_exis th_provs th_ty-       ; sig      <- repProto patSynSigDName nm1 ty1-       ; return (loc, sig) }-rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec--rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name-              -> DsM (SrcSpan, Core TH.DecQ)-rep_wc_ty_sig mk_sig loc sig_ty nm-  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm--rep_inline :: Located Name-           -> InlinePragma      -- Never defaultInlinePragma-           -> SrcSpan-           -> DsM [(SrcSpan, Core TH.DecQ)]-rep_inline nm ispec loc-  = do { nm1    <- lookupLOcc nm-       ; inline <- repInline $ inl_inline ispec-       ; rm     <- repRuleMatch $ inl_rule ispec-       ; phases <- repPhases $ inl_act ispec-       ; pragma <- repPragInl nm1 inline rm phases-       ; return [(loc, pragma)]-       }--rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma-               -> SrcSpan-               -> DsM [(SrcSpan, Core TH.DecQ)]-rep_specialise nm ty ispec loc-  = do { nm1 <- lookupLOcc nm-       ; ty1 <- repHsSigType ty-       ; phases <- repPhases $ inl_act ispec-       ; let inline = inl_inline ispec-       ; pragma <- if noUserInlineSpec inline-                   then -- SPECIALISE-                     repPragSpec nm1 ty1 phases-                   else -- SPECIALISE INLINE-                     do { inline1 <- repInline inline-                        ; repPragSpecInl nm1 ty1 inline1 phases }-       ; return [(loc, pragma)]-       }--rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan-                   -> DsM [(SrcSpan, Core TH.DecQ)]-rep_specialiseInst ty loc-  = do { ty1    <- repHsSigType ty-       ; pragma <- repPragSpecInst ty1-       ; return [(loc, pragma)] }--repInline :: InlineSpec -> DsM (Core TH.Inline)-repInline NoInline     = dataCon noInlineDataConName-repInline Inline       = dataCon inlineDataConName-repInline Inlinable    = dataCon inlinableDataConName-repInline NoUserInline = notHandled "NOUSERINLINE" empty--repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)-repRuleMatch ConLike = dataCon conLikeDataConName-repRuleMatch FunLike = dataCon funLikeDataConName--repPhases :: Activation -> DsM (Core TH.Phases)-repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i-                                  ; dataCon' beforePhaseDataConName [arg] }-repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i-                                  ; dataCon' fromPhaseDataConName [arg] }-repPhases _                  = dataCon allPhasesDataConName--rep_complete_sig :: Located [Located Name]-                 -> Maybe (Located Name)-                 -> SrcSpan-                 -> DsM [(SrcSpan, Core TH.DecQ)]-rep_complete_sig (L _ cls) mty loc-  = do { mty' <- repMaybe nameTyConName lookupLOcc mty-       ; cls' <- repList nameTyConName lookupLOcc cls-       ; sig <- repPragComplete cls' mty'-       ; return [(loc, sig)] }------------------------------------------------------------                      Types----------------------------------------------------------addSimpleTyVarBinds :: [Name]                -- the binders to be added-                    -> DsM (Core (TH.Q a))   -- action in the ext env-                    -> DsM (Core (TH.Q a))-addSimpleTyVarBinds names thing_inside-  = do { fresh_names <- mkGenSyms names-       ; term <- addBinds fresh_names thing_inside-       ; wrapGenSyms fresh_names term }--addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added-                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env-                -> DsM (Core (TH.Q a))-addHsTyVarBinds exp_tvs thing_inside-  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)-       ; term <- addBinds fresh_exp_names $-                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr-                                     (exp_tvs `zip` fresh_exp_names)-                    ; thing_inside kbs }-       ; wrapGenSyms fresh_exp_names term }-  where-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)--addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added-              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env-              -> DsM (Core (TH.Q a))--- gensym a list of type variables and enter them into the meta environment;--- the computations passed as the second argument is executed in that extended--- meta environment and gets the *new* names on Core-level as an argument-addTyVarBinds (HsQTvs { hsq_ext = imp_tvs-                      , hsq_explicit = exp_tvs })-              thing_inside-  = addSimpleTyVarBinds imp_tvs $-    addHsTyVarBinds exp_tvs $-    thing_inside-addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec--addTyClTyVarBinds :: LHsQTyVars GhcRn-                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))-                  -> DsM (Core (TH.Q a))---- Used for data/newtype declarations, and family instances,--- so that the nested type variables work right---    instance C (T a) where---      type W (T a) = blah--- The 'a' in the type instance is the one bound by the instance decl-addTyClTyVarBinds tvs m-  = do { let tv_names = hsAllLTyVarNames tvs-       ; env <- dsGetMetaEnv-       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)-            -- Make fresh names for the ones that are not already in scope-            -- This makes things work for family declarations--       ; term <- addBinds freshNames $-                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr-                                     (hsQTvExplicit tvs)-                    ; m kbs }--       ; wrapGenSyms freshNames term }-  where-    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)-    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)-                       ; repTyVarBndrWithKind tv v }---- Produce kinded binder constructors from the Haskell tyvar binders----repTyVarBndrWithKind :: LHsTyVarBndr GhcRn-                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)-repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm-  = repPlainTV nm-repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm-  = repLTy ki >>= repKindedTV nm-repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec---- | Represent a type variable binder-repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)-repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )-  = do { nm' <- lookupBinder nm-       ; repPlainTV nm' }-repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))-  = do { nm' <- lookupBinder nm-       ; ki' <- repLTy ki-       ; repKindedTV nm' ki' }-repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec---- represent a type context----repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)-repLContext ctxt = repContext (unLoc ctxt)--repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)-repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt-                     repCtxt preds--repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)-repHsSigType (HsIB { hsib_ext = implicit_tvs-                   , hsib_body = body })-  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body-  = addSimpleTyVarBinds implicit_tvs $-      -- See Note [Don't quantify implicit type variables in quotes]-    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->-    do { th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; if null explicit_tvs && null (unLoc ctxt)-         then return th_ty-         else repTForall th_explicit_tvs th_ctxt th_ty }-repHsSigType (XHsImplicitBndrs nec) = noExtCon nec--repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)-repHsSigWcType (HsWC { hswc_body = sig1 })-  = repHsSigType sig1-repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec---- yield the representation of a list of types-repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]-repLTys tys = mapM repLTy tys---- represent a type-repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)-repLTy ty = repTy (unLoc ty)--repForall :: ForallVisFlag -> HsType GhcRn -> DsM (Core TH.TypeQ)--- Arg of repForall is always HsForAllTy or HsQualTy-repForall fvf ty- | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)- = addHsTyVarBinds tvs $ \bndrs ->-   do { ctxt1  <- repLContext ctxt-      ; ty1    <- repLTy tau-      ; case fvf of-          ForallVis   -> repTForallVis bndrs ty1    -- forall a      -> {...}-          ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}-      }--repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)-repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf         ty-repTy ty@(HsQualTy {})                = repForall ForallInvis ty--repTy (HsTyVar _ _ (L _ n))-  | isLiftedTypeKindTyConName n       = repTStar-  | n `hasKey` constraintKindTyConKey = repTConstraint-  | n `hasKey` funTyConKey            = repArrowTyCon-  | isTvOcc occ   = do tv1 <- lookupOcc n-                       repTvar tv1-  | isDataOcc occ = do tc1 <- lookupOcc n-                       repPromotedDataCon tc1-  | n == eqTyConName = repTequality-  | otherwise     = do tc1 <- lookupOcc n-                       repNamedTyCon tc1-  where-    occ = nameOccName n--repTy (HsAppTy _ f a)       = do-                                f1 <- repLTy f-                                a1 <- repLTy a-                                repTapp f1 a1-repTy (HsAppKindTy _ ty ki) = do-                                ty1 <- repLTy ty-                                ki1 <- repLTy ki-                                repTappKind ty1 ki1-repTy (HsFunTy _ f a)       = do-                                f1   <- repLTy f-                                a1   <- repLTy a-                                tcon <- repArrowTyCon-                                repTapps tcon [f1, a1]-repTy (HsListTy _ t)        = do-                                t1   <- repLTy t-                                tcon <- repListTyCon-                                repTapp tcon t1-repTy (HsTupleTy _ HsUnboxedTuple tys) = do-                                tys1 <- repLTys tys-                                tcon <- repUnboxedTupleTyCon (length tys)-                                repTapps tcon tys1-repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys-                                 tcon <- repTupleTyCon (length tys)-                                 repTapps tcon tys1-repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys-                                 tcon <- repUnboxedSumTyCon (length tys)-                                 repTapps tcon tys1-repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)-                                   `nlHsAppTy` ty2)-repTy (HsParTy _ t)         = repLTy t-repTy (HsStarTy _ _) =  repTStar-repTy (HsKindSig _ t k)     = do-                                t1 <- repLTy t-                                k1 <- repLTy k-                                repTSig t1 k1-repTy (HsSpliceTy _ splice)      = repSplice splice-repTy (HsExplicitListTy _ _ tys) = do-                                    tys1 <- repLTys tys-                                    repTPromotedList tys1-repTy (HsExplicitTupleTy _ tys) = do-                                    tys1 <- repLTys tys-                                    tcon <- repPromotedTupleTyCon (length tys)-                                    repTapps tcon tys1-repTy (HsTyLit _ lit) = do-                          lit' <- repTyLit lit-                          repTLit lit'-repTy (HsWildCardTy _) = repTWildCard-repTy (HsIParamTy _ n t) = do-                             n' <- rep_implicit_param_name (unLoc n)-                             t' <- repLTy t-                             repTImplicitParam n' t'--repTy ty                      = notHandled "Exotic form of type" (ppr ty)--repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)-repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i-                            rep2 numTyLitName [iExpr]-repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s-                            ; rep2 strTyLitName [s']-                            }---- | Represent a type wrapped in a Maybe-repMaybeLTy :: Maybe (LHsKind GhcRn)-            -> DsM (Core (Maybe TH.TypeQ))-repMaybeLTy = repMaybe kindQTyConName repLTy--repRole :: Located (Maybe Role) -> DsM (Core TH.Role)-repRole (L _ (Just Nominal))          = rep2 nominalRName []-repRole (L _ (Just Representational)) = rep2 representationalRName []-repRole (L _ (Just Phantom))          = rep2 phantomRName []-repRole (L _ Nothing)                 = rep2 inferRName []----------------------------------------------------------------------------------              Splices--------------------------------------------------------------------------------repSplice :: HsSplice GhcRn -> DsM (Core a)--- See Note [How brackets and nested splices are handled] in TcSplice--- We return a CoreExpr of any old type; the context should know-repSplice (HsTypedSplice   _ _ n _) = rep_splice n-repSplice (HsUntypedSplice _ _ n _) = rep_splice n-repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n-repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)-repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)-repSplice (XSplice nec)             = noExtCon nec--rep_splice :: Name -> DsM (Core a)-rep_splice splice_name- = do { mb_val <- dsLookupMetaEnv splice_name-       ; case mb_val of-           Just (DsSplice e) -> do { e' <- dsExpr e-                                   ; return (MkC e') }-           _ -> pprPanic "HsSplice" (ppr splice_name) }-                        -- Should not happen; statically checked----------------------------------------------------------------------------------              Expressions--------------------------------------------------------------------------------repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])-repLEs es = repList expQTyConName repLE es---- FIXME: some of these panics should be converted into proper error messages---        unless we can make sure that constructs, which are plainly not---        supported in TH already lead to error messages at an earlier stage-repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)-repLE (L loc e) = putSrcSpanDs loc (repE e)--repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)-repE (HsVar _ (L _ x)) =-  do { mb_val <- dsLookupMetaEnv x-     ; case mb_val of-        Nothing            -> do { str <- globalVar x-                                 ; repVarOrCon x str }-        Just (DsBound y)   -> repVarOrCon x (coreVar y)-        Just (DsSplice e)  -> do { e' <- dsExpr e-                                 ; return (MkC e') } }-repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar-repE (HsOverLabel _ _ s) = repOverLabel s--repE e@(HsRecFld _ f) = case f of-  Unambiguous x _ -> repE (HsVar noExtField (noLoc x))-  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)-  XAmbiguousFieldOcc nec -> noExtCon nec--        -- Remember, we're desugaring renamer output here, so-        -- HsOverlit can definitely occur-repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }-repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }-repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m-repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))-                   = do { ms' <- mapM repMatchTup ms-                        ; core_ms <- coreList matchQTyConName ms'-                        ; repLamCase core_ms }-repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}-repE (HsAppType _ e t) = do { a <- repLE e-                            ; s <- repLTy (hswc_body t)-                            ; repAppType a s }--repE (OpApp _ e1 op e2) =-  do { arg1 <- repLE e1;-       arg2 <- repLE e2;-       the_op <- repLE op ;-       repInfixApp arg1 the_op arg2 }-repE (NegApp _ x _)      = do-                              a         <- repLE x-                              negateVar <- lookupOcc negateName >>= repVar-                              negateVar `repApp` a-repE (HsPar _ x)            = repLE x-repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }-repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }-repE (HsCase _ e (MG { mg_alts = (L _ ms) }))-                          = do { arg <- repLE e-                               ; ms2 <- mapM repMatchTup ms-                               ; core_ms2 <- coreList matchQTyConName ms2-                               ; repCaseE arg core_ms2 }-repE (HsIf _ _ x y z)       = do-                              a <- repLE x-                              b <- repLE y-                              c <- repLE z-                              repCond a b c-repE (HsMultiIf _ alts)-  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts-       ; expr' <- repMultiIf (nonEmptyCoreList alts')-       ; wrapGenSyms (concat binds) expr' }-repE (HsLet _ (L _ bs) e)       = do { (ss,ds) <- repBinds bs-                                     ; e2 <- addBinds ss (repLE e)-                                     ; z <- repLetE ds e2-                                     ; wrapGenSyms ss z }---- FIXME: I haven't got the types here right yet-repE e@(HsDo _ ctxt (L _ sts))- | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }- = do { (ss,zs) <- repLSts sts;-        e'      <- repDoE (nonEmptyCoreList zs);-        wrapGenSyms ss e' }-- | ListComp <- ctxt- = do { (ss,zs) <- repLSts sts;-        e'      <- repComp (nonEmptyCoreList zs);-        wrapGenSyms ss e' }-- | MDoExpr <- ctxt- = do { (ss,zs) <- repLSts sts;-        e'      <- repMDoE (nonEmptyCoreList zs);-        wrapGenSyms ss e' }--  | otherwise-  = notHandled "monad comprehension and [: :]" (ppr e)--repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }-repE (ExplicitTuple _ es boxity) =-  let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))-      tupArgToCoreExp (L _ a)-        | Present _ e <- a = do { e' <- repLE e-                                ; coreJust expQTyConName e' }-        | otherwise = coreNothing expQTyConName--  in do { args <- mapM tupArgToCoreExp es-        ; expQTy <- lookupType expQTyConName-        ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]-              listArg = coreList' maybeExpQTy args-        ; if isBoxed boxity-          then repTup listArg-          else repUnboxedTup listArg }--repE (ExplicitSum _ alt arity e)- = do { e1 <- repLE e-      ; repUnboxedSum e1 alt arity }--repE (RecordCon { rcon_con_name = c, rcon_flds = flds })- = do { x <- lookupLOcc c;-        fs <- repFields flds;-        repRecCon x fs }-repE (RecordUpd { rupd_expr = e, rupd_flds = flds })- = do { x <- repLE e;-        fs <- repUpdFields flds;-        repRecUpd x fs }--repE (ExprWithTySig _ e ty)-  = do { e1 <- repLE e-       ; t1 <- repHsSigWcType ty-       ; repSigExp e1 t1 }--repE (ArithSeq _ _ aseq) =-  case aseq of-    From e              -> do { ds1 <- repLE e; repFrom ds1 }-    FromThen e1 e2      -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             repFromThen ds1 ds2-    FromTo   e1 e2      -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             repFromTo ds1 ds2-    FromThenTo e1 e2 e3 -> do-                             ds1 <- repLE e1-                             ds2 <- repLE e2-                             ds3 <- repLE e3-                             repFromThenTo ds1 ds2 ds3--repE (HsSpliceE _ splice)  = repSplice splice-repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC-repE (HsUnboundVar _ uv)   = do-                               occ   <- occNameLit uv-                               sname <- repNameS occ-                               repUnboundVar sname--repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)-repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)-repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)-repE (XExpr nec)           = noExtCon nec-repE e                     = notHandled "Expression form" (ppr e)---------------------------------------------------------------------------------- Building representations of auxiliary structures like Match, Clause, Stmt,--repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)-repMatchTup (L _ (Match { m_pats = [p]-                        , m_grhss = GRHSs _ guards (L _ wheres) })) =-  do { ss1 <- mkGenSyms (collectPatBinders p)-     ; addBinds ss1 $ do {-     ; p1 <- repLP p-     ; (ss2,ds) <- repBinds wheres-     ; addBinds ss2 $ do {-     ; gs    <- repGuards guards-     ; match <- repMatch p1 gs ds-     ; wrapGenSyms (ss1++ss2) match }}}-repMatchTup _ = panic "repMatchTup: case alt with more than one arg"--repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)-repClauseTup (L _ (Match { m_pats = ps-                         , m_grhss = GRHSs _ guards (L _ wheres) })) =-  do { ss1 <- mkGenSyms (collectPatsBinders ps)-     ; addBinds ss1 $ do {-       ps1 <- repLPs ps-     ; (ss2,ds) <- repBinds wheres-     ; addBinds ss2 $ do {-       gs <- repGuards guards-     ; clause <- repClause ps1 gs ds-     ; wrapGenSyms (ss1++ss2) clause }}}-repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec-repClauseTup (L _ (XMatch nec)) = noExtCon nec--repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)-repGuards [L _ (GRHS _ [] e)]-  = do {a <- repLE e; repNormal a }-repGuards other-  = do { zs <- mapM repLGRHS other-       ; let (xs, ys) = unzip zs-       ; gd <- repGuarded (nonEmptyCoreList ys)-       ; wrapGenSyms (concat xs) gd }--repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)-         -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))-repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))-  = do { guarded <- repLNormalGE e1 e2-       ; return ([], guarded) }-repLGRHS (L _ (GRHS _ ss rhs))-  = do { (gs, ss') <- repLSts ss-       ; rhs' <- addBinds gs $ repLE rhs-       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'-       ; return (gs, guarded) }-repLGRHS (L _ (XGRHS nec)) = noExtCon nec--repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])-repFields (HsRecFields { rec_flds = flds })-  = repList fieldExpQTyConName rep_fld flds-  where-    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)-            -> DsM (Core (TH.Q TH.FieldExp))-    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)-                           ; e  <- repLE (hsRecFieldArg fld)-                           ; repFieldExp fn e }--repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])-repUpdFields = repList fieldExpQTyConName rep_fld-  where-    rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))-    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of-      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)-                                   ; e  <- repLE (hsRecFieldArg fld)-                                   ; repFieldExp fn e }-      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)-      XAmbiguousFieldOcc nec -> noExtCon nec------------------------------------------------------------------------------------ Representing Stmt's is tricky, especially if bound variables--- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]--- First gensym new names for every variable in any of the patterns.--- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))--- if variables didn't shadow, the static gensym wouldn't be necessary--- and we could reuse the original names (x and x).------ do { x'1 <- gensym "x"---    ; x'2 <- gensym "x"---    ; doE [ BindSt (pvar x'1) [| f 1 |]---          , BindSt (pvar x'2) [| f x |]---          , NoBindSt [| g x |]---          ]---    }---- The strategy is to translate a whole list of do-bindings by building a--- bigger environment, and a bigger set of meta bindings--- (like:  x'1 <- gensym "x" ) and then combining these with the translations--- of the expressions within the Do---------------------------------------------------------------------------------- The helper function repSts computes the translation of each sub expression--- and a bunch of prefix bindings denoting the dynamic renaming.--repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])-repLSts stmts = repSts (map unLoc stmts)--repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])-repSts (BindStmt _ p e _ _ : ss) =-   do { e2 <- repLE e-      ; ss1 <- mkGenSyms (collectPatBinders p)-      ; addBinds ss1 $ do {-      ; p1 <- repLP p;-      ; (ss2,zs) <- repSts ss-      ; z <- repBindSt p1 e2-      ; return (ss1++ss2, z : zs) }}-repSts (LetStmt _ (L _ bs) : ss) =-   do { (ss1,ds) <- repBinds bs-      ; z <- repLetSt ds-      ; (ss2,zs) <- addBinds ss1 (repSts ss)-      ; return (ss1++ss2, z : zs) }-repSts (BodyStmt _ e _ _ : ss) =-   do { e2 <- repLE e-      ; z <- repNoBindSt e2-      ; (ss2,zs) <- repSts ss-      ; return (ss2, z : zs) }-repSts (ParStmt _ stmt_blocks _ _ : ss) =-   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks-      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1-            ss1 = concat ss_s-      ; z <- repParSt stmt_blocks2-      ; (ss2, zs) <- addBinds ss1 (repSts ss)-      ; return (ss1++ss2, z : zs) }-   where-     rep_stmt_block :: ParStmtBlock GhcRn GhcRn-                    -> DsM ([GenSymBind], Core [TH.StmtQ])-     rep_stmt_block (ParStmtBlock _ stmts _ _) =-       do { (ss1, zs) <- repSts (map unLoc stmts)-          ; zs1 <- coreList stmtQTyConName zs-          ; return (ss1, zs1) }-     rep_stmt_block (XParStmtBlock nec) = noExtCon nec-repSts [LastStmt _ e _ _]-  = do { e2 <- repLE e-       ; z <- repNoBindSt e2-       ; return ([], [z]) }-repSts (stmt@RecStmt{} : ss)-  = do { let binders = collectLStmtsBinders (recS_stmts stmt)-       ; ss1 <- mkGenSyms binders-       -- Bring all of binders in the recursive group into scope for the-       -- whole group.-       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))-       ; MASSERT(sort ss1 == sort ss1_other)-       ; z <- repRecSt (nonEmptyCoreList rss)-       ; (ss2,zs) <- addBinds ss1 (repSts ss)-       ; return (ss1++ss2, z : zs) }-repSts (XStmtLR nec : _) = noExtCon nec-repSts []    = return ([],[])-repSts other = notHandled "Exotic statement" (ppr other)-----------------------------------------------------------------                      Bindings--------------------------------------------------------------repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])-repBinds (EmptyLocalBinds _)-  = do  { core_list <- coreList decQTyConName []-        ; return ([], core_list) }--repBinds (HsIPBinds _ (IPBinds _ decs))- = do   { ips <- mapM rep_implicit_param_bind decs-        ; core_list <- coreList decQTyConName-                                (de_loc (sort_by_loc ips))-        ; return ([], core_list)-        }--repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec--repBinds (HsValBinds _ decs)- = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }-                -- No need to worry about detailed scopes within-                -- the binding group, because we are talking Names-                -- here, so we can safely treat it as a mutually-                -- recursive group-                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]-        ; ss        <- mkGenSyms bndrs-        ; prs       <- addBinds ss (rep_val_binds decs)-        ; core_list <- coreList decQTyConName-                                (de_loc (sort_by_loc prs))-        ; return (ss, core_list) }-repBinds (XHsLocalBindsLR nec) = noExtCon nec--rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)-rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))- = do { name <- case ename of-                    Left (L _ n) -> rep_implicit_param_name n-                    Right _ ->-                        panic "rep_implicit_param_bind: post typechecking"-      ; rhs' <- repE rhs-      ; ipb <- repImplicitParamBind name rhs'-      ; return (loc, ipb) }-rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec--rep_implicit_param_name :: HsIPName -> DsM (Core String)-rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)--rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]--- Assumes: all the binders of the binding are already in the meta-env-rep_val_binds (XValBindsLR (NValBinds binds sigs))- = do { core1 <- rep_binds (unionManyBags (map snd binds))-      ; core2 <- rep_sigs sigs-      ; return (core1 ++ core2) }-rep_val_binds (ValBinds _ _ _)- = panic "rep_val_binds: ValBinds"--rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]-rep_binds = mapM rep_bind . bagToList--rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)--- Assumes: all the binders of the binding are already in the meta-env---- Note GHC treats declarations of a variable (not a pattern)--- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match--- with an empty list of patterns-rep_bind (L loc (FunBind-                 { fun_id = fn,-                   fun_matches = MG { mg_alts-                           = (L _ [L _ (Match-                                   { m_pats = []-                                   , m_grhss = GRHSs _ guards (L _ wheres) }-                                      )]) } }))- = do { (ss,wherecore) <- repBinds wheres-        ; guardcore <- addBinds ss (repGuards guards)-        ; fn'  <- lookupLBinder fn-        ; p    <- repPvar fn'-        ; ans  <- repVal p guardcore wherecore-        ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }--rep_bind (L loc (FunBind { fun_id = fn-                         , fun_matches = MG { mg_alts = L _ ms } }))- =   do { ms1 <- mapM repClauseTup ms-        ; fn' <- lookupLBinder fn-        ; ans <- repFun fn' (nonEmptyCoreList ms1)-        ; return (loc, ans) }--rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec--rep_bind (L loc (PatBind { pat_lhs = pat-                         , pat_rhs = GRHSs _ guards (L _ wheres) }))- =   do { patcore <- repLP pat-        ; (ss,wherecore) <- repBinds wheres-        ; guardcore <- addBinds ss (repGuards guards)-        ; ans  <- repVal patcore guardcore wherecore-        ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }-rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec--rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))- =   do { v' <- lookupBinder v-        ; e2 <- repLE e-        ; x <- repNormal e2-        ; patcore <- repPvar v'-        ; empty_decls <- coreList decQTyConName []-        ; ans <- repVal patcore x empty_decls-        ; return (srcLocSpan (getSrcLoc v), ans) }--rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"-rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn-                                   , psb_args = args-                                   , psb_def  = pat-                                   , psb_dir  = dir })))-  = do { syn'      <- lookupLBinder syn-       ; dir'      <- repPatSynDir dir-       ; ss        <- mkGenArgSyms args-       ; patSynD'  <- addBinds ss (-         do { args'  <- repPatSynArgs args-            ; pat'   <- repLP pat-            ; repPatSynD syn' args' dir' pat' })-       ; patSynD'' <- wrapGenArgSyms args ss patSynD'-       ; return (loc, patSynD'') }-  where-    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]-    -- for Record Pattern Synonyms we want to conflate the selector-    -- and the pattern-only names in order to provide a nicer TH-    -- API. Whereas inside GHC, record pattern synonym selectors and-    -- their pattern-only bound right hand sides have different names,-    -- we want to treat them the same in TH. This is the reason why we-    -- need an adjusted mkGenArgSyms in the `RecCon` case below.-    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)-    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]-    mkGenArgSyms (RecCon fields)-      = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (unLoc . recordPatSynSelectorId) fields-           ; ss <- mkGenSyms sels-           ; return $ replaceNames (zip sels pats) ss }--    replaceNames selsPats genSyms-      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats-                    , sel == sel' ]--    wrapGenArgSyms :: HsPatSynDetails (Located Name)-                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)-    wrapGenArgSyms (RecCon _) _  dec = return dec-    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec--rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec-rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec--repPatSynD :: Core TH.Name-           -> Core TH.PatSynArgsQ-           -> Core TH.PatSynDirQ-           -> Core TH.PatQ-           -> DsM (Core TH.DecQ)-repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)-  = rep2 patSynDName [syn, args, dir, pat]--repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)-repPatSynArgs (PrefixCon args)-  = do { args' <- repList nameTyConName lookupLOcc args-       ; repPrefixPatSynArgs args' }-repPatSynArgs (InfixCon arg1 arg2)-  = do { arg1' <- lookupLOcc arg1-       ; arg2' <- lookupLOcc arg2-       ; repInfixPatSynArgs arg1' arg2' }-repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName lookupLOcc sels-       ; repRecordPatSynArgs sels' }-  where sels = map recordPatSynSelectorId fields--repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)-repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]--repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)-repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]--repRecordPatSynArgs :: Core [TH.Name]-                    -> DsM (Core TH.PatSynArgsQ)-repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]--repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)-repPatSynDir Unidirectional        = rep2 unidirPatSynName []-repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []-repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))-  = do { clauses' <- mapM repClauseTup clauses-       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }-repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec--repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)-repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]----------------------------------------------------------------------------------- Since everything in a Bind is mutually recursive we need rename all--- all the variables simultaneously. For example:--- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to--- do { f'1 <- gensym "f"---    ; g'2 <- gensym "g"---    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},---        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}---      ]}--- This requires collecting the bindings (f'1 <- gensym "f"), and the--- environment ( f |-> f'1 ) from each binding, and then unioning them--- together. As we do this we collect GenSymBinds's which represent the renamed--- variables bound by the Bindings. In order not to lose track of these--- representations we build a shadow datatype MB with the same structure as--- MonoBinds, but which has slots for the representations----------------------------------------------------------------------------------- GHC allows a more general form of lambda abstraction than specified--- by Haskell 98. In particular it allows guarded lambda's like :--- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in--- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like--- (\ p1 .. pn -> exp) by causing an error.--repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)-repLambda (L _ (Match { m_pats = ps-                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]-                                          (L _ (EmptyLocalBinds _)) } ))- = do { let bndrs = collectPatsBinders ps ;-      ; ss  <- mkGenSyms bndrs-      ; lam <- addBinds ss (-                do { xs <- repLPs ps; body <- repLE e; repLam xs body })-      ; wrapGenSyms ss lam }-repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]-                                          (L _ (XHsLocalBindsLR nec)) } ))- = noExtCon nec--repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)-----------------------------------------------------------------------------------                      Patterns--- repP deals with patterns.  It assumes that we have already--- walked over the pattern(s) once to collect the binders, and--- have extended the environment.  So every pattern-bound--- variable should already appear in the environment.---- Process a list of patterns-repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])-repLPs ps = repList patQTyConName repLP ps--repLP :: LPat GhcRn -> DsM (Core TH.PatQ)-repLP p = repP (unLoc p)--repP :: Pat GhcRn -> DsM (Core TH.PatQ)-repP (WildPat _)        = repPwild-repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }-repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }-repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }-repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }-repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p-                             ; repPaspat x' p1 }-repP (ParPat _ p)       = repLP p-repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }-repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)-                                ; e' <- repE (syn_expr e)-                                ; repPview e' p}-repP (TuplePat _ ps boxed)-  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }-  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }-repP (SumPat _ p alt arity) = do { p1 <- repLP p-                                 ; repPunboxedSum p1 alt arity }-repP (ConPatIn dc details)- = do { con_str <- lookupLOcc dc-      ; case details of-         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }-         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)-                            ; repPrec con_str fps }-         InfixCon p1 p2 -> do { p1' <- repLP p1;-                                p2' <- repLP p2;-                                repPinfix p1' con_str p2' }-   }- where-   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))-   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)-                          ; MkC p <- repLP (hsRecFieldArg fld)-                          ; rep2 fieldPatName [v,p] }--repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l-                                     ; repPlit a }-repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }-repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)-repP (SigPat _ p t) = do { p' <- repLP p-                         ; t' <- repLTy (hsSigWcType t)-                         ; repPsig p' t' }-repP (SplicePat _ splice) = repSplice splice-repP (XPat nec) = noExtCon nec-repP other = notHandled "Exotic pattern" (ppr other)--------------------------------------------------------------- Declaration ordering helpers--sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]-sort_by_loc xs = sortBy comp xs-    where comp x y = compare (fst x) (fst y)--de_loc :: [(a, b)] -> [b]-de_loc = map snd---------------------------------------------------------------      The meta-environment---- A name/identifier association for fresh names of locally bound entities-type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id-                                -- I.e.         (x, x_id) means-                                --      let x_id = gensym "x" in ...---- Generate a fresh name for a locally bound entity--mkGenSyms :: [Name] -> DsM [GenSymBind]--- We can use the existing name.  For example:---      [| \x_77 -> x_77 + x_77 |]--- desugars to---      do { x_77 <- genSym "x"; .... }--- We use the same x_77 in the desugared program, but with the type Bndr--- instead of Int------ We do make it an Internal name, though (hence localiseName)------ Nevertheless, it's monadic because we have to generate nameTy-mkGenSyms ns = do { var_ty <- lookupType nameTyConName-                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }---addBinds :: [GenSymBind] -> DsM a -> DsM a--- Add a list of fresh names for locally bound entities to the--- meta environment (which is part of the state carried around--- by the desugarer monad)-addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m---- Look up a locally bound name----lookupLBinder :: Located Name -> DsM (Core TH.Name)-lookupLBinder n = lookupBinder (unLoc n)--lookupBinder :: Name -> DsM (Core TH.Name)-lookupBinder = lookupOcc-  -- Binders are brought into scope before the pattern or what-not is-  -- desugared.  Moreover, in instance declaration the binder of a method-  -- will be the selector Id and hence a global; so we need the-  -- globalVar case of lookupOcc---- Look up a name that is either locally bound or a global name------  * If it is a global name, generate the "original name" representation (ie,---   the <module>:<name> form) for the associated entity----lookupLOcc :: Located Name -> DsM (Core TH.Name)--- Lookup an occurrence; it can't be a splice.--- Use the in-scope bindings if they exist-lookupLOcc n = lookupOcc (unLoc n)--lookupOcc :: Name -> DsM (Core TH.Name)-lookupOcc n-  = do {  mb_val <- dsLookupMetaEnv n ;-          case mb_val of-                Nothing           -> globalVar n-                Just (DsBound x)  -> return (coreVar x)-                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)-    }--globalVar :: Name -> DsM (Core TH.Name)--- Not bound by the meta-env--- Could be top-level; or could be local---      f x = $(g [| x |])--- Here the x will be local-globalVar name-  | isExternalName name-  = do  { MkC mod <- coreStringLit name_mod-        ; MkC pkg <- coreStringLit name_pkg-        ; MkC occ <- nameLit name-        ; rep2 mk_varg [pkg,mod,occ] }-  | otherwise-  = do  { MkC occ <- nameLit name-        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))-        ; rep2 mkNameLName [occ,uni] }-  where-      mod = ASSERT( isExternalName name) nameModule name-      name_mod = moduleNameString (moduleName mod)-      name_pkg = unitIdString (moduleUnitId mod)-      name_occ = nameOccName name-      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName-              | OccName.isVarOcc  name_occ = mkNameG_vName-              | OccName.isTcOcc   name_occ = mkNameG_tcName-              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)--lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)-           -> DsM Type  -- The type-lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;-                          return (mkTyConApp tc []) }--wrapGenSyms :: [GenSymBind]-            -> Core (TH.Q a) -> DsM (Core (TH.Q a))--- wrapGenSyms [(nm1,id1), (nm2,id2)] y---      --> bindQ (gensym nm1) (\ id1 ->---          bindQ (gensym nm2 (\ id2 ->---          y))--wrapGenSyms binds body@(MkC b)-  = do  { var_ty <- lookupType nameTyConName-        ; go var_ty binds }-  where-    [elt_ty] = tcTyConAppArgs (exprType b)-        -- b :: Q a, so we can get the type 'a' by looking at the-        -- argument type. NB: this relies on Q being a data/newtype,-        -- not a type synonym--    go _ [] = return body-    go var_ty ((name,id) : binds)-      = do { MkC body'  <- go var_ty binds-           ; lit_str    <- nameLit name-           ; gensym_app <- repGensym lit_str-           ; repBindQ var_ty elt_ty-                      gensym_app (MkC (Lam id body')) }--nameLit :: Name -> DsM (Core String)-nameLit n = coreStringLit (occNameString (nameOccName n))--occNameLit :: OccName -> DsM (Core String)-occNameLit name = coreStringLit (occNameString name)----- %*********************************************************************--- %*                                                                   *---              Constructing code--- %*                                                                   *--- %*********************************************************************---------------------------------------------------------------------------------- PHANTOM TYPES for consistency. In order to make sure we do this correct--- we invent a new datatype which uses phantom types.--newtype Core a = MkC CoreExpr-unC :: Core a -> CoreExpr-unC (MkC x) = x--rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)-rep2 n xs = do { id <- dsLookupGlobalId n-               ; return (MkC (foldl' App (Var id) xs)) }--dataCon' :: Name -> [CoreExpr] -> DsM (Core a)-dataCon' n args = do { id <- dsLookupDataCon n-                     ; return $ MkC $ mkCoreConApps id args }--dataCon :: Name -> DsM (Core a)-dataCon n = dataCon' n []----- %*********************************************************************--- %*                                                                   *---              The 'smart constructors'--- %*                                                                   *--- %*********************************************************************----------------- Patterns ------------------repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)-repPlit (MkC l) = rep2 litPName [l]--repPvar :: Core TH.Name -> DsM (Core TH.PatQ)-repPvar (MkC s) = rep2 varPName [s]--repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPtup (MkC ps) = rep2 tupPName [ps]--repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]--repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here-repPunboxedSum (MkC p) alt arity- = do { dflags <- getDynFlags-      ; rep2 unboxedSumPName [ p-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags arity ] }--repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]--repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)-repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]--repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]--repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)-repPtilde (MkC p) = rep2 tildePName [p]--repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)-repPbang (MkC p) = rep2 bangPName [p]--repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]--repPwild  :: DsM (Core TH.PatQ)-repPwild = rep2 wildPName []--repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)-repPlist (MkC ps) = rep2 listPName [ps]--repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)-repPview (MkC e) (MkC p) = rep2 viewPName [e,p]--repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]----------------- Expressions ------------------repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str-                   | otherwise                  = repVar str--repVar :: Core TH.Name -> DsM (Core TH.ExpQ)-repVar (MkC s) = rep2 varEName [s]--repCon :: Core TH.Name -> DsM (Core TH.ExpQ)-repCon (MkC s) = rep2 conEName [s]--repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)-repLit (MkC c) = rep2 litEName [c]--repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repApp (MkC x) (MkC y) = rep2 appEName [x,y]--repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)-repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]--repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]--repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)-repLamCase (MkC ms) = rep2 lamCaseEName [ms]--repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)-repTup (MkC es) = rep2 tupEName [es]--repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)-repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]--repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here-repUnboxedSum (MkC e) alt arity- = do { dflags <- getDynFlags-      ; rep2 unboxedSumEName [ e-                             , mkIntExprInt dflags alt-                             , mkIntExprInt dflags arity ] }--repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]--repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)-repMultiIf (MkC alts) = rep2 multiIfEName [alts]--repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]--repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM (Core TH.ExpQ)-repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]--repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repDoE (MkC ss) = rep2 doEName [ss]--repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repMDoE (MkC ss) = rep2 mdoEName [ss]--repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)-repComp (MkC ss) = rep2 compEName [ss]--repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)-repListExp (MkC es) = rep2 listEName [es]--repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)-repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]--repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]--repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)-repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]--repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))-repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]--repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]--repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]--repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]--repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)-repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]-------------- Right hand sides (guarded expressions) -----repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)-repGuarded (MkC pairs) = rep2 guardedBName [pairs]--repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)-repNormal (MkC e) = rep2 normalBName [e]-------------- Guards -----repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn-             -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repLNormalGE g e = do g' <- repLE g-                      e' <- repLE e-                      repNormalGE g' e'--repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]--repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))-repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]--------------- Stmts --------------------repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)-repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]--repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)-repLetSt (MkC ds) = rep2 letSName [ds]--repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)-repNoBindSt (MkC e) = rep2 noBindSName [e]--repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)-repParSt (MkC sss) = rep2 parSName [sss]--repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)-repRecSt (MkC ss) = rep2 recSName [ss]---------------- Range (Arithmetic sequences) ------------repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFrom (MkC x) = rep2 fromEName [x]--repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]--repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]--repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]-------------- Match and Clause Tuples ------------repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)-repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]--repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)-repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]---------------- Dec ------------------------------repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)-repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]--repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)-repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]--repData :: Core TH.CxtQ -> Core TH.Name-        -> Either (Core [TH.TyVarBndrQ])-                  (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)-        -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]-        -> DsM (Core TH.DecQ)-repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)-  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]-repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)-        (MkC derivs)-  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]--repNewtype :: Core TH.CxtQ -> Core TH.Name-           -> Either (Core [TH.TyVarBndrQ])-                     (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)-           -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]-           -> DsM (Core TH.DecQ)-repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)-           (MkC derivs)-  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]-repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)-           (MkC derivs)-  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]--repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]-         -> Core TH.TypeQ -> DsM (Core TH.DecQ)-repTySyn (MkC nm) (MkC tvs) (MkC rhs)-  = rep2 tySynDName [nm, tvs, rhs]--repInst :: Core (Maybe TH.Overlap) ->-           Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)-repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName-                                                              [o, cxt, ty, ds]--repDerivStrategy :: Maybe (LDerivStrategy GhcRn)-                 -> DsM (Core (Maybe TH.DerivStrategyQ))-repDerivStrategy mds =-  case mds of-    Nothing -> nothing-    Just ds ->-      case unLoc ds of-        StockStrategy    -> just =<< repStockStrategy-        AnyclassStrategy -> just =<< repAnyclassStrategy-        NewtypeStrategy  -> just =<< repNewtypeStrategy-        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)-                               via_strat <- repViaStrategy ty'-                               just via_strat-  where-  nothing = coreNothing derivStrategyQTyConName-  just    = coreJust    derivStrategyQTyConName--repStockStrategy :: DsM (Core TH.DerivStrategyQ)-repStockStrategy = rep2 stockStrategyName []--repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)-repAnyclassStrategy = rep2 anyclassStrategyName []--repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)-repNewtypeStrategy = rep2 newtypeStrategyName []--repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)-repViaStrategy (MkC t) = rep2 viaStrategyName [t]--repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))-repOverlap mb =-  case mb of-    Nothing -> nothing-    Just o ->-      case o of-        NoOverlap _    -> nothing-        Overlappable _ -> just =<< dataCon overlappableDataConName-        Overlapping _  -> just =<< dataCon overlappingDataConName-        Overlaps _     -> just =<< dataCon overlapsDataConName-        Incoherent _   -> just =<< dataCon incoherentDataConName-  where-  nothing = coreNothing overlapTyConName-  just    = coreJust overlapTyConName---repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]-         -> Core [TH.FunDep] -> Core [TH.DecQ]-         -> DsM (Core TH.DecQ)-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)-  = rep2 classDName [cxt, cls, tvs, fds, ds]--repDeriv :: Core (Maybe TH.DerivStrategyQ)-         -> Core TH.CxtQ -> Core TH.TypeQ-         -> DsM (Core TH.DecQ)-repDeriv (MkC ds) (MkC cxt) (MkC ty)-  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]--repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch-           -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)-  = rep2 pragInlDName [nm, inline, rm, phases]--repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases-            -> DsM (Core TH.DecQ)-repPragSpec (MkC nm) (MkC ty) (MkC phases)-  = rep2 pragSpecDName [nm, ty, phases]--repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline-               -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)-  = rep2 pragSpecInlDName [nm, ty, inline, phases]--repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)-repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]--repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)-repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]--repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])-            -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ-            -> Core TH.Phases -> DsM (Core TH.DecQ)-repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)-  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]--repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)-repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]--repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)-repTySynInst (MkC eqn)-    = rep2 tySynInstDName [eqn]--repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]-               -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)-repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)-    = rep2 dataFamilyDName [nm, tvs, kind]--repOpenFamilyD :: Core TH.Name-               -> Core [TH.TyVarBndrQ]-               -> Core TH.FamilyResultSigQ-               -> Core (Maybe TH.InjectivityAnn)-               -> DsM (Core TH.DecQ)-repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)-    = rep2 openTypeFamilyDName [nm, tvs, result, inj]--repClosedFamilyD :: Core TH.Name-                 -> Core [TH.TyVarBndrQ]-                 -> Core TH.FamilyResultSigQ-                 -> Core (Maybe TH.InjectivityAnn)-                 -> Core [TH.TySynEqnQ]-                 -> DsM (Core TH.DecQ)-repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)-    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]--repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->-               Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)-repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)-  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]--repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)-repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]--repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)-repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]--repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)-repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]--repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)-repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]--repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)-repCtxt (MkC tys) = rep2 cxtName [tys]--repDataCon :: Located Name-           -> HsConDeclDetails GhcRn-           -> DsM (Core TH.ConQ)-repDataCon con details-    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]-         repConstr details Nothing [con']--repGadtDataCons :: [Located Name]-                -> HsConDeclDetails GhcRn-                -> LHsType GhcRn-                -> DsM (Core TH.ConQ)-repGadtDataCons cons details res_ty-    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]-         repConstr details (Just res_ty) cons'---- Invariant:---   * for plain H98 data constructors second argument is Nothing and third---     argument is a singleton list---   * for GADTs data constructors second argument is (Just return_type) and---     third argument is a non-empty list-repConstr :: HsConDeclDetails GhcRn-          -> Maybe (LHsType GhcRn)-          -> [Core TH.Name]-          -> DsM (Core TH.ConQ)-repConstr (PrefixCon ps) Nothing [con]-    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps-         rep2 normalCName [unC con, unC arg_tys]--repConstr (PrefixCon ps) (Just res_ty) cons-    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps-         res_ty' <- repLTy res_ty-         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']--repConstr (RecCon ips) resTy cons-    = do args     <- concatMapM rep_ip (unLoc ips)-         arg_vtys <- coreList varBangTypeQTyConName args-         case resTy of-           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]-           Just res_ty -> do-             res_ty' <- repLTy res_ty-             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,-                                unC res_ty']--    where-      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)--      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)-      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)-                          ; MkC ty <- repBangTy  t-                          ; rep2 varBangTypeName [v,ty] }--repConstr (InfixCon st1 st2) Nothing [con]-    = do arg1 <- repBangTy st1-         arg2 <- repBangTy st2-         rep2 infixCName [unC arg1, unC con, unC arg2]--repConstr (InfixCon {}) (Just _) _ =-    panic "repConstr: infix GADT constructor should be in a PrefixCon"-repConstr _ _ _ =-    panic "repConstr: invariant violated"-------------- Types ---------------------repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ-           -> DsM (Core TH.TypeQ)-repTForall (MkC tvars) (MkC ctxt) (MkC ty)-    = rep2 forallTName [tvars, ctxt, ty]--repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ-              -> DsM (Core TH.TypeQ)-repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]--repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)-repTvar (MkC s) = rep2 varTName [s]--repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)-repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]--repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)-repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]--repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)-repTapps f []     = return f-repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }--repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)-repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]--repTequality :: DsM (Core TH.TypeQ)-repTequality = rep2 equalityTName []--repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)-repTPromotedList []     = repPromotedNilTyCon-repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon-                              ; f <- repTapp tcon t-                              ; t' <- repTPromotedList ts-                              ; repTapp f t'-                              }--repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)-repTLit (MkC lit) = rep2 litTName [lit]--repTWildCard :: DsM (Core TH.TypeQ)-repTWildCard = rep2 wildCardTName []--repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)-repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]--repTStar :: DsM (Core TH.TypeQ)-repTStar = rep2 starKName []--repTConstraint :: DsM (Core TH.TypeQ)-repTConstraint = rep2 constraintKName []----------- Type constructors ----------------repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)-repNamedTyCon (MkC s) = rep2 conTName [s]--repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ-             -> DsM (Core TH.TypeQ)-repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]--repTupleTyCon :: Int -> DsM (Core TH.TypeQ)--- Note: not Core Int; it's easier to be direct here-repTupleTyCon i = do dflags <- getDynFlags-                     rep2 tupleTName [mkIntExprInt dflags i]--repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)--- Note: not Core Int; it's easier to be direct here-repUnboxedTupleTyCon i = do dflags <- getDynFlags-                            rep2 unboxedTupleTName [mkIntExprInt dflags i]--repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)--- Note: not Core TH.SumArity; it's easier to be direct here-repUnboxedSumTyCon arity = do dflags <- getDynFlags-                              rep2 unboxedSumTName [mkIntExprInt dflags arity]--repArrowTyCon :: DsM (Core TH.TypeQ)-repArrowTyCon = rep2 arrowTName []--repListTyCon :: DsM (Core TH.TypeQ)-repListTyCon = rep2 listTName []--repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)-repPromotedDataCon (MkC s) = rep2 promotedTName [s]--repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)-repPromotedTupleTyCon i = do dflags <- getDynFlags-                             rep2 promotedTupleTName [mkIntExprInt dflags i]--repPromotedNilTyCon :: DsM (Core TH.TypeQ)-repPromotedNilTyCon = rep2 promotedNilTName []--repPromotedConsTyCon :: DsM (Core TH.TypeQ)-repPromotedConsTyCon = rep2 promotedConsTName []-------------- TyVarBndrs ---------------------repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)-repPlainTV (MkC nm) = rep2 plainTVName [nm]--repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)-repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]---------------------------------------------------------------       Type family result signature--repNoSig :: DsM (Core TH.FamilyResultSigQ)-repNoSig = rep2 noSigName []--repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)-repKindSig (MkC ki) = rep2 kindSigName [ki]--repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)-repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]---------------------------------------------------------------              Literals--repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)-repLiteral (HsStringPrim _ bs)-  = do dflags   <- getDynFlags-       word8_ty <- lookupType word8TyConName-       let w8s = unpack bs-           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon-                                  [mkWordLit dflags (toInteger w8)]) w8s-       rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]-repLiteral lit-  = do lit' <- case lit of-                   HsIntPrim _ i    -> mk_integer i-                   HsWordPrim _ w   -> mk_integer w-                   HsInt _ i        -> mk_integer (il_value i)-                   HsFloatPrim _ r  -> mk_rational r-                   HsDoublePrim _ r -> mk_rational r-                   HsCharPrim _ c   -> mk_char c-                   _ -> return lit-       lit_expr <- dsLit lit'-       case mb_lit_name of-          Just lit_name -> rep2 lit_name [lit_expr]-          Nothing -> notHandled "Exotic literal" (ppr lit)-  where-    mb_lit_name = case lit of-                 HsInteger _ _ _  -> Just integerLName-                 HsInt _ _        -> Just integerLName-                 HsIntPrim _ _    -> Just intPrimLName-                 HsWordPrim _ _   -> Just wordPrimLName-                 HsFloatPrim _ _  -> Just floatPrimLName-                 HsDoublePrim _ _ -> Just doublePrimLName-                 HsChar _ _       -> Just charLName-                 HsCharPrim _ _   -> Just charPrimLName-                 HsString _ _     -> Just stringLName-                 HsRat _ _ _      -> Just rationalLName-                 _                -> Nothing--mk_integer :: Integer -> DsM (HsLit GhcRn)-mk_integer  i = do integer_ty <- lookupType integerTyConName-                   return $ HsInteger NoSourceText i integer_ty--mk_rational :: FractionalLit -> DsM (HsLit GhcRn)-mk_rational r = do rat_ty <- lookupType rationalTyConName-                   return $ HsRat noExtField r rat_ty-mk_string :: FastString -> DsM (HsLit GhcRn)-mk_string s = return $ HsString NoSourceText s--mk_char :: Char -> DsM (HsLit GhcRn)-mk_char c = return $ HsChar NoSourceText c--repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)-repOverloadedLiteral (OverLit { ol_val = val})-  = do { lit <- mk_lit val; repLiteral lit }-        -- The type Rational will be in the environment, because-        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,-        -- and rationalL is sucked in when any TH stuff is used-repOverloadedLiteral (XOverLit nec) = noExtCon nec--mk_lit :: OverLitVal -> DsM (HsLit GhcRn)-mk_lit (HsIntegral i)     = mk_integer  (il_value i)-mk_lit (HsFractional f)   = mk_rational f-mk_lit (HsIsString _ s)   = mk_string   s--repNameS :: Core String -> DsM (Core TH.Name)-repNameS (MkC name) = rep2 mkNameSName [name]----------------- Miscellaneous ---------------------repGensym :: Core String -> DsM (Core (TH.Q TH.Name))-repGensym (MkC lit_str) = rep2 newNameName [lit_str]--repBindQ :: Type -> Type        -- a and b-         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))-repBindQ ty_a ty_b (MkC x) (MkC y)-  = rep2 bindQName [Type ty_a, Type ty_b, x, y]--repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))-repSequenceQ ty_a (MkC list)-  = rep2 sequenceQName [Type ty_a, list]--repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)-repUnboundVar (MkC name) = rep2 unboundVarEName [name]--repOverLabel :: FastString -> DsM (Core TH.ExpQ)-repOverLabel fs = do-                    (MkC s) <- coreStringLit $ unpackFS fs-                    rep2 labelEName [s]--------------- Lists ---------------------- turn a list of patterns into a single pattern matching a list--repList :: Name -> (a  -> DsM (Core b))-                    -> [a] -> DsM (Core [b])-repList tc_name f args-  = do { args1 <- mapM f args-       ; coreList tc_name args1 }--coreList :: Name    -- Of the TyCon of the element type-         -> [Core a] -> DsM (Core [a])-coreList tc_name es-  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }--coreList' :: Type       -- The element type-          -> [Core a] -> Core [a]-coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))--nonEmptyCoreList :: [Core a] -> Core [a]-  -- The list must be non-empty so we can get the element type-  -- Otherwise use coreList-nonEmptyCoreList []           = panic "coreList: empty argument"-nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))--coreStringLit :: String -> DsM (Core String)-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }--------------------- Maybe --------------------repMaybe :: Name -> (a -> DsM (Core b))-                    -> Maybe a -> DsM (Core (Maybe b))-repMaybe tc_name _ Nothing   = coreNothing tc_name-repMaybe tc_name f (Just es) = coreJust tc_name =<< f es---- | Construct Core expression for Nothing of a given type name-coreNothing :: Name        -- ^ Name of the TyCon of the element type-            -> DsM (Core (Maybe a))-coreNothing tc_name =-    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }---- | Construct Core expression for Nothing of a given type-coreNothing' :: Type       -- ^ The element type-             -> Core (Maybe a)-coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)---- | Store given Core expression in a Just of a given type name-coreJust :: Name        -- ^ Name of the TyCon of the element type-         -> Core a -> DsM (Core (Maybe a))-coreJust tc_name es-  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }---- | Store given Core expression in a Just of a given type-coreJust' :: Type       -- ^ The element type-          -> Core a -> Core (Maybe a)-coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))--------------------- Maybe Lists --------------------repMaybeList :: Name -> (a -> DsM (Core b))-                        -> Maybe [a] -> DsM (Core (Maybe [b]))-repMaybeList tc_name _ Nothing = coreNothingList tc_name-repMaybeList tc_name f (Just args)-  = do { elt_ty <- lookupType tc_name-       ; args1 <- mapM f args-       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }--coreNothingList :: Name -> DsM (Core (Maybe [a]))-coreNothingList tc_name-  = do { elt_ty <- lookupType tc_name-       ; return $ coreNothing' (mkListTy elt_ty) }--coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))-coreJustList tc_name args-  = do { elt_ty <- lookupType tc_name-       ; return $ coreJust' (mkListTy elt_ty) args }-------------- Literals & Variables ---------------------coreIntLit :: Int -> DsM (Core Int)-coreIntLit i = do dflags <- getDynFlags-                  return (MkC (mkIntExprInt dflags i))--coreIntegerLit :: Integer -> DsM (Core Integer)-coreIntegerLit i = fmap MkC (mkIntegerExpr i)--coreVar :: Id -> Core TH.Name   -- The Id has type Name-coreVar id = MkC (Var id)------------------- Failure ------------------------notHandledL :: SrcSpan -> String -> SDoc -> DsM a-notHandledL loc what doc-  | isGoodSrcSpan loc-  = putSrcSpanDs loc $ notHandled what doc-  | otherwise-  = notHandled what doc--notHandled :: String -> SDoc -> DsM a-notHandled what doc = failWithDs msg+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2006+--+-- The purpose of this module is to transform an HsExpr into a CoreExpr which+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the+-- input HsExpr. We do this in the DsM monad, which supplies access to+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.+--+-- It also defines a bunch of knownKeyNames, in the same way as is done+-- in prelude/PrelNames.  It's much more convenient to do it here, because+-- otherwise we have to recompile PrelNames whenever we add a Name, which is+-- a Royal Pain (triggers other recompilation).+-----------------------------------------------------------------------------++module DsMeta( dsBracket ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   DsExpr ( dsExpr )++import MatchLit+import DsMonad++import qualified Language.Haskell.TH as TH++import GHC.Hs+import PrelNames+-- To avoid clashes with DsMeta.varName we must make a local alias for+-- OccName.varName we do this by removing varName from the import of+-- OccName above, making a qualified instance of OccName and using+-- OccNameAlias.varName where varName ws previously used in this file.+import qualified OccName( isDataOcc, isVarOcc, isTcOcc )++import Module+import Id+import Name hiding( isVarOcc, isTcOcc, varName, tcName )+import THNames+import NameEnv+import TcType+import TyCon+import TysWiredIn+import CoreSyn+import MkCore+import CoreUtils+import SrcLoc+import Unique+import BasicTypes+import Outputable+import Bag+import DynFlags+import FastString+import ForeignCall+import Util+import Maybes+import MonadUtils+import TcEvidence+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class+import Class+import HscTypes ( MonadThings )+import DataCon+import Var+import DsBinds++import GHC.TypeLits+import Data.Kind (Constraint)++import Data.ByteString ( unpack )+import Control.Monad+import Data.List++data MetaWrappers = MetaWrappers {+      -- Applies its argument to a type argument `m` and dictionary `Quote m`+      quoteWrapper :: CoreExpr -> CoreExpr+      -- Apply its argument to a type argument `m` and a dictionary `Monad m`+    , monadWrapper :: CoreExpr -> CoreExpr+      -- Apply the container typed variable `m` to the argument type `T` to get `m T`.+    , metaTy :: Type -> Type+      -- Information about the wrappers which be printed to be inspected+    , _debugWrappers :: (HsWrapper, HsWrapper, Type)+    }++-- | Construct the functions which will apply the relevant part of the+-- QuoteWrapper to identifiers during desugaring.+mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers+mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do+      let quote_var = Var quote_var_raw+      -- Get the superclass selector to select the Monad dictionary, going+      -- to be used to construct the monadWrapper.+      quote_tc <- dsLookupTyCon quoteClassName+      monad_tc <- dsLookupTyCon monadClassName+      let Just cls = tyConClass_maybe quote_tc+          Just monad_cls = tyConClass_maybe monad_tc+          -- Quote m -> Monad m+          monad_sel = classSCSelId cls 0++          -- Only used for the defensive assertion that the selector has+          -- the expected type+          tyvars = dataConUserTyVarBinders (classDataCon cls)+          expected_ty = mkForAllTys tyvars $+                          mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars)))+                                       (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))++      MASSERT2( idType monad_sel `eqType` expected_ty, ppr monad_sel $$ ppr expected_ty)++      let m_ty = Type m_var+          -- Construct the contents of MetaWrappers+          quoteWrapper = applyQuoteWrapper q+          monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>+                            mkWpTyApps [m_var]+          tyWrapper t = mkAppTy m_var t+          debug = (quoteWrapper, monadWrapper, m_var)+      q_f <- dsHsWrapper quoteWrapper+      m_f <- dsHsWrapper monadWrapper+      return (MetaWrappers q_f m_f tyWrapper debug)++-- Turn A into m A+wrapName :: Name -> MetaM Type+wrapName n = do+  t <- lookupType n+  wrap_fn <- asks metaTy+  return (wrap_fn t)++-- The local state is always the same, calculated from the passed in+-- wrapper+type MetaM a = ReaderT MetaWrappers DsM a++-----------------------------------------------------------------------------+dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr+          -> HsBracket GhcRn+          -> [PendingTcSplice]+          -> DsM CoreExpr+-- See Note [Desugaring Brackets]+-- Returns a CoreExpr of type (M TH.Exp)+-- The quoted thing is parameterised over Name, even though it has+-- been type checked.  We don't want all those type decorations!++dsBracket wrap brack splices+  = do_brack brack++  where+    runOverloaded act = do+      -- In the overloaded case we have to get given a wrapper, it is just+      -- for variable quotations that there is no wrapper, because they+      -- have a simple type.+      mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)+      runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw+++    new_bit = mkNameEnv [(n, DsSplice (unLoc e))+                        | PendingTcSplice n e <- splices]++    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM n ; return e1 }+    do_brack (ExpBr _ e)   = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }+    do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }+    do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }+    do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"+    do_brack (TExpBr _ e)  = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }+    do_brack (XBracket nec) = noExtCon nec++{-+Note [Desugaring Brackets]+~~~~~~~~~~~~~~~~~~~~~~~~~~++In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie+an expression bracket was of type Q Exp. This made the desugaring process simple+as there were no complicated type variables to keep consistent throughout the+whole AST. Due to the overloaded quotations proposal a quotation bracket is now+of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been+generalised to work with any monad implementing a minimal interface.++https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst++Users can rejoice at the flexibility but now there is some additional complexity in+how brackets are desugared as all these polymorphic combinators need their arguments+instantiated.++> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD+> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.++What the arguments should be instantiated to is supplied by the `QuoteWrapper`+datatype which is produced by `TcSplice`. It is a pair of an evidence variable+for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring+need to be applied to these two type variables.++There are three important functions which do the application.++1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.+2. `rep2M` takes a function name of type `Monad m => T` as an argument+3. `rep2_nw` takes a function name without any constraints as an argument.++These functions then use the information in QuoteWrapper to apply the correct+arguments to the functions as the representation is constructed.++The `MetaM` monad carries around an environment of three functions which are+used in order to wrap the polymorphic combinators and instantiate the arguments+to the correct things.++1. quoteWrapper wraps functions of type `forall m . Quote m => T`+2. monadWrapper wraps functions of type `forall m . Monad m => T`+3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.++Historical note about the implementation: At the first attempt, I attempted to+lie that the type of any quotation was `Quote m => m Exp` and then specialise it+by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was+simpler to implement but didn't work because of nested splices. For example,+you might have a nested splice of a more specific type which fixes the type of+the overall quote and so all the combinators used must also be instantiated to+that specific type. Therefore you really have to use the contents of the quote+wrapper to directly apply the right type to the combinators rather than+first generate a polymorphic definition and then just apply the wrapper at the end.++-}++{- -------------- Examples --------------------++  [| \x -> x |]+====>+  gensym (unpackString "x"#) `bindQ` \ x1::String ->+  lam (pvar x1) (var x1)+++  [| \x -> $(f [| x |]) |]+====>+  gensym (unpackString "x"#) `bindQ` \ x1::String ->+  lam (pvar x1) (f (var x1))+-}+++-------------------------------------------------------+--                      Declarations+-------------------------------------------------------++-- Proxy for the phantom type of `Core`. All the generated fragments have+-- type something like `Quote m => m Exp` so to keep things simple we represent fragments+-- of that type as `M Exp`.+data M a++repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)+                 ; pat' <- addBinds ss (repLP pat)+                 ; wrapGenSyms ss pat' }++repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))+repTopDs group@(HsGroup { hs_valds   = valds+                        , hs_splcds  = splcds+                        , hs_tyclds  = tyclds+                        , hs_derivds = derivds+                        , hs_fixds   = fixds+                        , hs_defds   = defds+                        , hs_fords   = fords+                        , hs_warnds  = warnds+                        , hs_annds   = annds+                        , hs_ruleds  = ruleds+                        , hs_docs    = docs })+ = do { let { bndrs  = hsScopedTvBinders valds+                       ++ hsGroupBinders group+                       ++ hsPatSynSelectors valds+            ; instds = tyclds >>= group_instds } ;+        ss <- mkGenSyms bndrs ;++        -- Bind all the names mainly to avoid repeated use of explicit strings.+        -- Thus we get+        --      do { t :: String <- genSym "T" ;+        --           return (Data t [] ...more t's... }+        -- The other important reason is that the output must mention+        -- only "T", not "Foo:T" where Foo is the current module++        decls <- addBinds ss (+                  do { val_ds   <- rep_val_binds valds+                     ; _        <- mapM no_splice splcds+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)+                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)+                     ; inst_ds  <- mapM repInstD instds+                     ; deriv_ds <- mapM repStandaloneDerivD derivds+                     ; fix_ds   <- mapM repLFixD fixds+                     ; _        <- mapM no_default_decl defds+                     ; for_ds   <- mapM repForD fords+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)+                                                           warnds)+                     ; ann_ds   <- mapM repAnnD annds+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)+                                                            ruleds)+                     ; _        <- mapM no_doc docs++                        -- more needed+                     ;  return (de_loc $ sort_by_loc $+                                val_ds ++ catMaybes tycl_ds ++ role_ds+                                       ++ kisig_ds+                                       ++ (concat fix_ds)+                                       ++ inst_ds ++ rule_ds ++ for_ds+                                       ++ ann_ds ++ deriv_ds) }) ;++        core_list <- repListM decTyConName return decls ;++        dec_ty <- lookupType decTyConName ;+        q_decs  <- repSequenceM dec_ty core_list ;++        wrapGenSyms ss q_decs+      }+  where+    no_splice (L loc _)+      = notHandledL loc "Splices within declaration brackets" empty+    no_default_decl (L loc decl)+      = notHandledL loc "Default declarations" (ppr decl)+    no_warn (L loc (Warning _ thing _))+      = notHandledL loc "WARNING and DEPRECATION pragmas" $+                    text "Pragma for declaration of" <+> ppr thing+    no_warn (L _ (XWarnDecl nec)) = noExtCon nec+    no_doc (L loc _)+      = notHandledL loc "Haddock documentation" empty+repTopDs (XHsGroup nec) = noExtCon nec++hsScopedTvBinders :: HsValBinds GhcRn -> [Name]+-- See Note [Scoped type variables in bindings]+hsScopedTvBinders binds+  = concatMap get_scoped_tvs sigs+  where+    sigs = case binds of+             ValBinds           _ _ sigs  -> sigs+             XValBindsLR (NValBinds _ sigs) -> sigs++get_scoped_tvs :: LSig GhcRn -> [Name]+get_scoped_tvs (L _ signature)+  | TypeSig _ _ sig <- signature+  = get_scoped_tvs_from_sig (hswc_body sig)+  | ClassOpSig _ _ _ sig <- signature+  = get_scoped_tvs_from_sig sig+  | PatSynSig _ _ sig <- signature+  = get_scoped_tvs_from_sig sig+  | otherwise+  = []+  where+    get_scoped_tvs_from_sig sig+      -- Both implicit and explicit quantified variables+      -- We need the implicit ones for   f :: forall (a::k). blah+      --    here 'k' scopes too+      | HsIB { hsib_ext = implicit_vars+             , hsib_body = hs_ty } <- sig+      , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty+      = implicit_vars ++ hsLTyVarNames explicit_vars+    get_scoped_tvs_from_sig (XHsImplicitBndrs nec)+      = noExtCon nec++{- Notes++Note [Scoped type variables in bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: forall a. a -> a+   f x = x::a+Here the 'forall a' brings 'a' into scope over the binding group.+To achieve this we++  a) Gensym a binding for 'a' at the same time as we do one for 'f'+     collecting the relevant binders with hsScopedTvBinders++  b) When processing the 'forall', don't gensym++The relevant places are signposted with references to this Note++Note [Scoped type variables in class and instance declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Scoped type variables may occur in default methods and default+signatures. We need to bring the type variables in 'foralls'+into the scope of the method bindings.++Consider+   class Foo a where+     foo :: forall (b :: k). a -> Proxy b -> Proxy b+     foo _ x = (x :: Proxy b)++We want to ensure that the 'b' in the type signature and the default+implementation are the same, so we do the following:++  a) Before desugaring the signature and binding of 'foo', use+     get_scoped_tvs to collect type variables in 'forall' and+     create symbols for them.+  b) Use 'addBinds' to bring these symbols into the scope of the type+     signatures and bindings.+  c) Use these symbols to generate Core for the class/instance declaration.++Note that when desugaring the signatures, we lookup the type variables+from the scope rather than recreate symbols for them. See more details+in "rep_ty_sig" and in Trac#14885.++Note [Binders and occurrences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we desugar [d| data T = MkT |]+we want to get+        Data "T" [] [Con "MkT" []] []+and *not*+        Data "Foo:T" [] [Con "Foo:MkT" []] []+That is, the new data decl should fit into whatever new module it is+asked to fit in.   We do *not* clone, though; no need for this:+        Data "T79" ....++But if we see this:+        data T = MkT+        foo = reifyDecl T++then we must desugar to+        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []++So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.+And we use lookupOcc, rather than lookupBinder+in repTyClD and repC.++Note [Don't quantify implicit type variables in quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you're not careful, it's surprisingly easy to take this quoted declaration:++  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b+      idProxy x = x+    |]++and have Template Haskell turn it into this:++  idProxy :: forall k proxy (b :: k). proxy b -> proxy b+  idProxy x = x++Notice that we explicitly quantified the variable `k`! The latter declaration+isn't what the user wrote in the first place.++Usually, the culprit behind these bugs is taking implicitly quantified type+variables (often from the hsib_vars field of HsImplicitBinders) and putting+them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.+-}++-- represent associated family instances+--+repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))++repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $+                                              repFamilyDecl (L loc fam)++repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                repSynDecl tc1 bndrs rhs+       ; return (Just (loc, dec)) }++repTyClD (L loc (DataDecl { tcdLName = tc+                          , tcdTyVars = tvs+                          , tcdDataDefn = defn }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                repDataDefn tc1 (Left bndrs) defn+       ; return (Just (loc, dec)) }++repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,+                             tcdTyVars = tvs, tcdFDs = fds,+                             tcdSigs = sigs, tcdMeths = meth_binds,+                             tcdATs = ats, tcdATDefs = atds }))+  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]+       ; dec  <- addTyVarBinds tvs $ \bndrs ->+           do { cxt1   <- repLContext cxt+          -- See Note [Scoped type variables in class and instance declarations]+              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds+              ; fds1   <- repLFunDeps fds+              ; ats1   <- repFamilyDecls ats+              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds+              ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1+              ; wrapGenSyms ss decls2 }+       ; return $ Just (loc, dec)+       }++repTyClD (L _ (XTyClDecl nec)) = noExtCon nec++-------------------------+repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repRoleD (L loc (RoleAnnotDecl _ tycon roles))+  = do { tycon1 <- lookupLOcc tycon+       ; roles1 <- mapM repRole roles+       ; roles2 <- coreList roleTyConName roles1+       ; dec <- repRoleAnnotD tycon1 roles2+       ; return (loc, dec) }+repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec++-------------------------+repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repKiSigD (L loc kisig) =+  case kisig of+    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v+    XStandaloneKindSig nec -> noExtCon nec++-------------------------+repDataDefn :: Core TH.Name+            -> Either (Core [(M TH.TyVarBndr)])+                        -- the repTyClD case+                      (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))+                        -- the repDataFamInstD case+            -> HsDataDefn GhcRn+            -> MetaM (Core (M TH.Dec))+repDataDefn tc opts+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig+                      , dd_cons = cons, dd_derivs = mb_derivs })+  = do { cxt1     <- repLContext cxt+       ; derivs1  <- repDerivs mb_derivs+       ; case (new_or_data, cons) of+           (NewType, [con])  -> do { con'  <- repC con+                                   ; ksig' <- repMaybeLTy ksig+                                   ; repNewtype cxt1 tc opts ksig' con'+                                                derivs1 }+           (NewType, _) -> lift $ failWithDs (text "Multiple constructors for newtype:"+                                       <+> pprQuotedList+                                       (getConNames $ unLoc $ head cons))+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig+                               ; consL <- mapM repC cons+                               ; cons1 <- coreListM conTyConName consL+                               ; repData cxt1 tc opts ksig' cons1+                                         derivs1 }+       }+repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec++repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)]+           -> LHsType GhcRn+           -> MetaM (Core (M TH.Dec))+repSynDecl tc bndrs ty+  = do { ty1 <- repLTy ty+       ; repTySyn tc bndrs ty1 }++repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info+                                      , fdLName     = tc+                                      , fdTyVars    = tvs+                                      , fdResultSig = L _ resultSig+                                      , fdInjectivityAnn = injectivity }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn+             mkHsQTvs tvs = HsQTvs { hsq_ext = []+                                   , hsq_explicit = tvs }+             resTyVar = case resultSig of+                     TyVarSig _ bndr -> mkHsQTvs [bndr]+                     _               -> mkHsQTvs []+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                addTyClTyVarBinds resTyVar $ \_ ->+           case info of+             ClosedTypeFamily Nothing ->+                 notHandled "abstract closed type family" (ppr decl)+             ClosedTypeFamily (Just eqns) ->+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns+                  ; eqns2  <- coreListM tySynEqnTyConName eqns1+                  ; result <- repFamilyResultSig resultSig+                  ; inj    <- repInjectivityAnn injectivity+                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }+             OpenTypeFamily ->+               do { result <- repFamilyResultSig resultSig+                  ; inj    <- repInjectivityAnn injectivity+                  ; repOpenFamilyD tc1 bndrs result inj }+             DataFamily ->+               do { kind <- repFamilyResultSigToMaybeKind resultSig+                  ; repDataFamilyD tc1 bndrs kind }+       ; return (loc, dec)+       }+repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec++-- | Represent result signature of a type family+repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))+repFamilyResultSig (NoSig _)         = repNoSig+repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki+                                          ; repKindSig ki' }+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr+                                          ; repTyVarSig bndr' }+repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec++-- | Represent result signature using a Maybe Kind. Used with data families,+-- where the result signature can be either missing or a kind but never a named+-- result variable.+repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn+                              -> MetaM (Core (Maybe (M TH.Kind)))+repFamilyResultSigToMaybeKind (NoSig _) =+    do { coreNothingM kindTyConName }+repFamilyResultSigToMaybeKind (KindSig _ ki) =+    do { coreJustM kindTyConName =<< repLTy ki }+repFamilyResultSigToMaybeKind TyVarSig{} =+    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"+repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec++-- | Represent injectivity annotation of a type family+repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)+                  -> MetaM (Core (Maybe TH.InjectivityAnn))+repInjectivityAnn Nothing =+    do { coreNothing injAnnTyConName }+repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =+    do { lhs'   <- lookupBinder (unLoc lhs)+       ; rhs1   <- mapM (lookupBinder . unLoc) rhs+       ; rhs2   <- coreList nameTyConName rhs1+       ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]+       ; coreJust injAnnTyConName injAnn }++repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)++repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))+repAssocTyFamDefaultD = repTyFamInstD++-------------------------+-- represent fundeps+--+repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])+repLFunDeps fds = repList funDepTyConName repLFunDep fds++repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)+repLFunDep (L _ (xs, ys))+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys+        repFunDep xs' ys'++-- Represent instance declarations+--+repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))+  = do { dec <- repTyFamInstD fi_decl+       ; return (loc, dec) }+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))+  = do { dec <- repDataFamInstD fi_decl+       ; return (loc, dec) }+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))+  = do { dec <- repClsInstD cls_decl+       ; return (loc, dec) }+repInstD (L _ (XInstDecl nec)) = noExtCon nec++repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds+                         , cid_sigs = sigs, cid_tyfam_insts = ats+                         , cid_datafam_insts = adts+                         , cid_overlap_mode = overlap+                         })+  = addSimpleTyVarBinds tvs $+            -- We must bring the type variables into scope, so their+            -- occurrences don't fail, even though the binders don't+            -- appear in the resulting data structure+            --+            -- But we do NOT bring the binders of 'binds' into scope+            -- because they are properly regarded as occurrences+            -- For example, the method names should be bound to+            -- the selector Ids, not to fresh names (#5410)+            --+            do { cxt1     <- repLContext cxt+               ; inst_ty1 <- repLTy inst_ty+          -- See Note [Scoped type variables in class and instance declarations]+               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds+               ; ats1   <- mapM (repTyFamInstD . unLoc) ats+               ; adts1  <- mapM (repDataFamInstD . unLoc) adts+               ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)+               ; rOver  <- repOverlap (fmap unLoc overlap)+               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1+               ; wrapGenSyms ss decls2 }+ where+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty+repClsInstD (XClsInstDecl nec) = noExtCon nec++repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat+                                       , deriv_type     = ty }))+  = do { dec <- addSimpleTyVarBinds tvs $+                do { cxt'     <- repLContext cxt+                   ; strat'   <- repDerivStrategy strat+                   ; inst_ty' <- repLTy inst_ty+                   ; repDeriv strat' cxt' inst_ty' }+       ; return (loc, dec) }+  where+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)+repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec++repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))+repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })+  = do { eqn1 <- repTyFamEqn eqn+       ; repTySynInst eqn1 }++repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))+repTyFamEqn (HsIB { hsib_ext = var_names+                  , hsib_body = FamEqn { feqn_tycon = tc_name+                                       , feqn_bndrs = mb_bndrs+                                       , feqn_pats = tys+                                       , feqn_fixity = fixity+                                       , feqn_rhs  = rhs }})+  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]+       ; let hs_tvs = HsQTvs { hsq_ext = var_names+                             , hsq_explicit = fromMaybe [] mb_bndrs }+       ; addTyClTyVarBinds hs_tvs $ \ _ ->+         do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName+                                        repTyVarBndr+                                        mb_bndrs+            ; tys1 <- case fixity of+                        Prefix -> repTyArgs (repNamedTyCon tc) tys+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys+                                     ; t1' <- repLTy t1+                                     ; t2'  <- repLTy t2+                                     ; repTyArgs (repTInfix t1' tc t2') args }+            ; rhs1 <- repLTy rhs+            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }+     where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]+           checkTys tys@(HsValArg _:HsValArg _:_) = return tys+           checkTys _ = panic "repTyFamEqn:checkTys"+repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec+repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec++repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))+repTyArgs f [] = f+repTyArgs f (HsValArg ty : as) = do { f' <- f+                                    ; ty' <- repLTy ty+                                    ; repTyArgs (repTapp f' ty') as }+repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f+                                       ; ki' <- repLTy ki+                                       ; repTyArgs (repTappKind f' ki') as }+repTyArgs f (HsArgPar _ : as) = repTyArgs f as++repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))+repDataFamInstD (DataFamInstDecl { dfid_eqn =+                  (HsIB { hsib_ext = var_names+                        , hsib_body = FamEqn { feqn_tycon = tc_name+                                             , feqn_bndrs = mb_bndrs+                                             , feqn_pats  = tys+                                             , feqn_fixity = fixity+                                             , feqn_rhs   = defn }})})+  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]+       ; let hs_tvs = HsQTvs { hsq_ext = var_names+                             , hsq_explicit = fromMaybe [] mb_bndrs }+       ; addTyClTyVarBinds hs_tvs $ \ _ ->+         do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName+                                        repTyVarBndr+                                        mb_bndrs+            ; tys1 <- case fixity of+                        Prefix -> repTyArgs (repNamedTyCon tc) tys+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys+                                     ; t1' <- repLTy t1+                                     ; t2'  <- repLTy t2+                                     ; repTyArgs (repTInfix t1' tc t2') args }+            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }++      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]+            checkTys tys@(HsValArg _: HsValArg _: _) = return tys+            checkTys _ = panic "repDataFamInstD:checkTys"++repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))+  = noExtCon nec+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))+  = noExtCon nec++repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ+                                  , fd_fi = CImport (L _ cc)+                                                    (L _ s) mch cis _ }))+ = do MkC name' <- lookupLOcc name+      MkC typ' <- repHsSigType typ+      MkC cc' <- repCCallConv cc+      MkC s' <- repSafety s+      cis' <- conv_cimportspec cis+      MkC str <- coreStringLit (static ++ chStr ++ cis')+      dec <- rep2 forImpDName [cc', s', str, name', typ']+      return (loc, dec)+ where+    conv_cimportspec (CLabel cls)+      = notHandled "Foreign label" (doubleQuotes (ppr cls))+    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))+                            = return (unpackFS fs)+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))+                            = panic "conv_cimportspec: values not supported yet"+    conv_cimportspec CWrapper = return "wrapper"+    -- these calling conventions do not support headers and the static keyword+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv+    static = case cis of+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "+                 _ -> ""+    chStr = case mch of+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "+            _ -> ""+repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)+repForD (L _ (XForeignDecl nec)) = noExtCon nec++repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)+repCCallConv CCallConv          = rep2_nw cCallName []+repCCallConv StdCallConv        = rep2_nw stdCallName []+repCCallConv CApiConv           = rep2_nw cApiCallName []+repCCallConv PrimCallConv       = rep2_nw primCallName []+repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []++repSafety :: Safety -> MetaM (Core TH.Safety)+repSafety PlayRisky = rep2_nw unsafeName []+repSafety PlayInterruptible = rep2_nw interruptibleName []+repSafety PlaySafe = rep2_nw safeName []++repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]+repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig++rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))+  = do { MkC prec' <- coreIntLit prec+       ; let rep_fn = case dir of+                        InfixL -> infixLDName+                        InfixR -> infixRDName+                        InfixN -> infixNDName+       ; let do_one name+              = do { MkC name' <- lookupLOcc name+                   ; dec <- rep2 rep_fn [prec', name']+                   ; return (loc,dec) }+       ; mapM do_one names }+rep_fix_d _ (XFixitySig nec) = noExtCon nec++repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repRuleD (L loc (HsRule { rd_name = n+                        , rd_act = act+                        , rd_tyvs = ty_bndrs+                        , rd_tmvs = tm_bndrs+                        , rd_lhs = lhs+                        , rd_rhs = rhs }))+  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->+         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs+            ; ss <- mkGenSyms tm_bndr_names+            ; rule <- addBinds ss $+                      do { elt_ty <- wrapName tyVarBndrTyConName+                         ; ty_bndrs' <- return $ case ty_bndrs of+                             Nothing -> coreNothing' (mkListTy elt_ty)+                             Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs+                         ; tm_bndrs' <- repListM ruleBndrTyConName+                                                repRuleBndr+                                                tm_bndrs+                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n+                         ; act' <- repPhases act+                         ; lhs' <- repLE lhs+                         ; rhs' <- repLE rhs+                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }+           ; wrapGenSyms ss rule  }+       ; return (loc, rule) }+repRuleD (L _ (XRuleDecl nec)) = noExtCon nec++ruleBndrNames :: LRuleBndr GhcRn -> [Name]+ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]+ruleBndrNames (L _ (RuleBndrSig _ n sig))+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig+  = unLoc n : vars+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))+  = noExtCon nec+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))+  = noExtCon nec+ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec++repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))+repRuleBndr (L _ (RuleBndr _ n))+  = do { MkC n' <- lookupLBinder n+       ; rep2 ruleVarName [n'] }+repRuleBndr (L _ (RuleBndrSig _ n sig))+  = do { MkC n'  <- lookupLBinder n+       ; MkC ty' <- repLTy (hsSigWcType sig)+       ; rep2 typedRuleVarName [n', ty'] }+repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec++repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))+  = do { target <- repAnnProv ann_prov+       ; exp'   <- repE exp+       ; dec    <- repPragAnn target exp'+       ; return (loc, dec) }+repAnnD (L _ (XAnnDecl nec)) = noExtCon nec++repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)+repAnnProv (ValueAnnProvenance (L _ n))+  = do { MkC n' <- lift $ globalVar n  -- ANNs are allowed only at top-level+       ; rep2_nw valueAnnotationName [ n' ] }+repAnnProv (TypeAnnProvenance (L _ n))+  = do { MkC n' <- lift $ globalVar n+       ; rep2_nw typeAnnotationName [ n' ] }+repAnnProv ModuleAnnProvenance+  = rep2_nw moduleAnnotationName []++-------------------------------------------------------+--                      Constructors+-------------------------------------------------------++repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))+repC (L _ (ConDeclH98 { con_name   = con+                      , con_forall = (L _ False)+                      , con_mb_cxt = Nothing+                      , con_args   = args }))+  = repDataCon con args++repC (L _ (ConDeclH98 { con_name = con+                      , con_forall = L _ is_existential+                      , con_ex_tvs = con_tvs+                      , con_mb_cxt = mcxt+                      , con_args = args }))+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->+         do { c'    <- repDataCon con args+            ; ctxt' <- repMbContext mcxt+            ; if not is_existential && isNothing mcxt+              then return c'+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])+            }+       }++repC (L _ (ConDeclGADT { con_names  = cons+                       , con_qvars  = qtvs+                       , con_mb_cxt = mcxt+                       , con_args   = args+                       , con_res_ty = res_ty }))+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables+  , Nothing <- mcxt      -- No context+                         -- ==> no need for a forall+  = repGadtDataCons cons args res_ty++  | otherwise+  = addTyVarBinds qtvs $ \ ex_bndrs ->+             -- See Note [Don't quantify implicit type variables in quotes]+    do { c'    <- repGadtDataCons cons args res_ty+       ; ctxt' <- repMbContext mcxt+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt+         then return c'+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }++repC (L _ (XConDecl nec)) = noExtCon nec+++repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))+repMbContext Nothing          = repContext []+repMbContext (Just (L _ cxt)) = repContext cxt++repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []++repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []++repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))+repBangTy ty = do+  MkC u <- repSrcUnpackedness su'+  MkC s <- repSrcStrictness ss'+  MkC b <- rep2 bangName [u, s]+  MkC t <- repLTy ty'+  rep2 bangTypeName [b, t]+  where+    (su', ss', ty') = case unLoc ty of+            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)+            _ -> (NoSrcUnpack, NoSrcStrict, ty)++-------------------------------------------------------+--                      Deriving clauses+-------------------------------------------------------++repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])+repDerivs (L _ clauses)+  = repListM derivClauseTyConName repDerivClause clauses++repDerivClause :: LHsDerivingClause GhcRn+               -> MetaM (Core (M TH.DerivClause))+repDerivClause (L _ (HsDerivingClause+                          { deriv_clause_strategy = dcs+                          , deriv_clause_tys      = L _ dct }))+  = do MkC dcs' <- repDerivStrategy dcs+       MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct+       rep2 derivClauseName [dcs',dct']+  where+    rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))+    rep_deriv_ty ty = repLTy ty+repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec++rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn+               -> MetaM ([GenSymBind], [Core (M TH.Dec)])+-- Represent signatures and methods in class/instance declarations.+-- See Note [Scoped type variables in class and instance declarations]+--+-- Why not use 'repBinds': we have already created symbols for methods in+-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate+-- these fun_id via 'collectHsValBinders decs', which would lead to the+-- instance declarations failing in TH.+rep_sigs_binds sigs binds+  = do { let tvs = concatMap get_scoped_tvs sigs+       ; ss <- mkGenSyms tvs+       ; sigs1 <- addBinds ss $ rep_sigs sigs+       ; binds1 <- addBinds ss $ rep_binds binds+       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }++-------------------------------------------------------+--   Signatures in a class decl, or a group of bindings+-------------------------------------------------------++rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]+        -- We silently ignore ones we don't recognise+rep_sigs = concatMapM rep_sig++rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_sig (L loc (TypeSig _ nms ty))+  = mapM (rep_wc_ty_sig sigDName loc ty) nms+rep_sig (L loc (PatSynSig _ nms ty))+  = mapM (rep_patsyn_ty_sig loc ty) nms+rep_sig (L loc (ClassOpSig _ is_deflt nms ty))+  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms+  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms+rep_sig d@(L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)+rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d loc fix_sig+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc+rep_sig (L loc (SpecSig _ nm tys ispec))+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys+rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc+rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty+rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty+rep_sig (L loc (CompleteMatchSig _ _st cls mty))+  = rep_complete_sig cls mty loc+rep_sig (L _ (XSig nec)) = noExtCon nec++rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name+           -> MetaM (SrcSpan, Core (M TH.Dec))+-- Don't create the implicit and explicit variables when desugaring signatures,+-- see Note [Scoped type variables in class and instance declarations].+-- and Note [Don't quantify implicit type variables in quotes]+rep_ty_sig mk_sig loc sig_ty nm+  | HsIB { hsib_body = hs_ty } <- sig_ty+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty+  = do { nm1 <- lookupLOcc nm+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+                                     ; repTyVarBndrWithKind tv name }+       ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv+                                    explicit_tvs++         -- NB: Don't pass any implicit type variables to repList above+         -- See Note [Don't quantify implicit type variables in quotes]++       ; th_ctxt <- repLContext ctxt+       ; th_ty   <- repLTy ty+       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)+                       then return th_ty+                       else repTForall th_explicit_tvs th_ctxt th_ty+       ; sig     <- repProto mk_sig nm1 ty1+       ; return (loc, sig) }+rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec++rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name+                  -> MetaM (SrcSpan, Core (M TH.Dec))+-- represents a pattern synonym type signature;+-- see Note [Pattern synonym type signatures and Template Haskell] in Convert+--+-- Don't create the implicit and explicit variables when desugaring signatures,+-- see Note [Scoped type variables in class and instance declarations]+-- and Note [Don't quantify implicit type variables in quotes]+rep_patsyn_ty_sig loc sig_ty nm+  | HsIB { hsib_body = hs_ty } <- sig_ty+  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty+  = do { nm1 <- lookupLOcc nm+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+                                     ; repTyVarBndrWithKind tv name }+       ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs+       ; th_exis  <- repListM tyVarBndrTyConName rep_in_scope_tv exis++         -- NB: Don't pass any implicit type variables to repList above+         -- See Note [Don't quantify implicit type variables in quotes]++       ; th_reqs  <- repLContext reqs+       ; th_provs <- repLContext provs+       ; th_ty    <- repLTy ty+       ; ty1      <- repTForall th_univs th_reqs =<<+                       repTForall th_exis th_provs th_ty+       ; sig      <- repProto patSynSigDName nm1 ty1+       ; return (loc, sig) }+rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec++rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name+              -> MetaM (SrcSpan, Core (M TH.Dec))+rep_wc_ty_sig mk_sig loc sig_ty nm+  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm++rep_inline :: Located Name+           -> InlinePragma      -- Never defaultInlinePragma+           -> SrcSpan+           -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_inline nm ispec loc+  = do { nm1    <- lookupLOcc nm+       ; inline <- repInline $ inl_inline ispec+       ; rm     <- repRuleMatch $ inl_rule ispec+       ; phases <- repPhases $ inl_act ispec+       ; pragma <- repPragInl nm1 inline rm phases+       ; return [(loc, pragma)]+       }++rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma+               -> SrcSpan+               -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_specialise nm ty ispec loc+  = do { nm1 <- lookupLOcc nm+       ; ty1 <- repHsSigType ty+       ; phases <- repPhases $ inl_act ispec+       ; let inline = inl_inline ispec+       ; pragma <- if noUserInlineSpec inline+                   then -- SPECIALISE+                     repPragSpec nm1 ty1 phases+                   else -- SPECIALISE INLINE+                     do { inline1 <- repInline inline+                        ; repPragSpecInl nm1 ty1 inline1 phases }+       ; return [(loc, pragma)]+       }++rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan+                   -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_specialiseInst ty loc+  = do { ty1    <- repHsSigType ty+       ; pragma <- repPragSpecInst ty1+       ; return [(loc, pragma)] }++repInline :: InlineSpec -> MetaM (Core TH.Inline)+repInline NoInline     = dataCon noInlineDataConName+repInline Inline       = dataCon inlineDataConName+repInline Inlinable    = dataCon inlinableDataConName+repInline NoUserInline = notHandled "NOUSERINLINE" empty++repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)+repRuleMatch ConLike = dataCon conLikeDataConName+repRuleMatch FunLike = dataCon funLikeDataConName++repPhases :: Activation -> MetaM (Core TH.Phases)+repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i+                                  ; dataCon' beforePhaseDataConName [arg] }+repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i+                                  ; dataCon' fromPhaseDataConName [arg] }+repPhases _                  = dataCon allPhasesDataConName++rep_complete_sig :: Located [Located Name]+                 -> Maybe (Located Name)+                 -> SrcSpan+                 -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_complete_sig (L _ cls) mty loc+  = do { mty' <- repMaybe nameTyConName lookupLOcc mty+       ; cls' <- repList nameTyConName lookupLOcc cls+       ; sig <- repPragComplete cls' mty'+       ; return [(loc, sig)] }++-------------------------------------------------------+--                      Types+-------------------------------------------------------++addSimpleTyVarBinds :: [Name]                -- the binders to be added+                    -> MetaM (Core (M a))   -- action in the ext env+                    -> MetaM (Core (M a))+addSimpleTyVarBinds names thing_inside+  = do { fresh_names <- mkGenSyms names+       ; term <- addBinds fresh_names thing_inside+       ; wrapGenSyms fresh_names term }++addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added+                -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))  -- action in the ext env+                -> MetaM (Core (M a))+addHsTyVarBinds exp_tvs thing_inside+  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)+       ; term <- addBinds fresh_exp_names $+                 do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr+                                     (exp_tvs `zip` fresh_exp_names)+                    ; thing_inside kbs }+       ; wrapGenSyms fresh_exp_names term }+  where+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)++addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added+              -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))  -- action in the ext env+              -> MetaM (Core (M a))+-- gensym a list of type variables and enter them into the meta environment;+-- the computations passed as the second argument is executed in that extended+-- meta environment and gets the *new* names on Core-level as an argument+addTyVarBinds (HsQTvs { hsq_ext = imp_tvs+                      , hsq_explicit = exp_tvs })+              thing_inside+  = addSimpleTyVarBinds imp_tvs $+    addHsTyVarBinds exp_tvs $+    thing_inside+addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec++addTyClTyVarBinds :: LHsQTyVars GhcRn+                  -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))+                  -> MetaM (Core (M a))++-- Used for data/newtype declarations, and family instances,+-- so that the nested type variables work right+--    instance C (T a) where+--      type W (T a) = blah+-- The 'a' in the type instance is the one bound by the instance decl+addTyClTyVarBinds tvs m+  = do { let tv_names = hsAllLTyVarNames tvs+       ; env <- lift $ dsGetMetaEnv+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)+            -- Make fresh names for the ones that are not already in scope+            -- This makes things work for family declarations++       ; term <- addBinds freshNames $+                 do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr+                                     (hsQTvExplicit tvs)+                    ; m kbs }++       ; wrapGenSyms freshNames term }+  where+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))+    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)+                       ; repTyVarBndrWithKind tv v }++-- Produce kinded binder constructors from the Haskell tyvar binders+--+repTyVarBndrWithKind :: LHsTyVarBndr GhcRn+                     -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr))+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm+  = repPlainTV nm+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm+  = repLTy ki >>= repKindedTV nm+repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec++-- | Represent a type variable binder+repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )+  = do { nm' <- lookupBinder nm+       ; repPlainTV nm' }+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))+  = do { nm' <- lookupBinder nm+       ; ki' <- repLTy ki+       ; repKindedTV nm' ki' }+repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec++-- represent a type context+--+repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt))+repLContext ctxt = repContext (unLoc ctxt)++repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))+repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt+                     repCtxt preds++repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))+repHsSigType (HsIB { hsib_ext = implicit_tvs+                   , hsib_body = body })+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body+  = addSimpleTyVarBinds implicit_tvs $+      -- See Note [Don't quantify implicit type variables in quotes]+    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->+    do { th_ctxt <- repLContext ctxt+       ; th_ty   <- repLTy ty+       ; if null explicit_tvs && null (unLoc ctxt)+         then return th_ty+         else repTForall th_explicit_tvs th_ctxt th_ty }+repHsSigType (XHsImplicitBndrs nec) = noExtCon nec++repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))+repHsSigWcType (HsWC { hswc_body = sig1 })+  = repHsSigType sig1+repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec++-- yield the representation of a list of types+repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]+repLTys tys = mapM repLTy tys++-- represent a type+repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))+repLTy ty = repTy (unLoc ty)++-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or+-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.+-- In other words, the argument to this function is always an+-- @HsForAllTy ForallInvis@ or @HsQualTy@.+-- Types headed by visible foralls (which are desugared to ForallVisT) are+-- handled separately in repTy.+repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))+repForallT ty+ | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)+ = addHsTyVarBinds tvs $ \bndrs ->+   do { ctxt1  <- repLContext ctxt+      ; tau1   <- repLTy tau+      ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}+      }++repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))+repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) =+  case fvf of+    ForallInvis -> repForallT ty+    ForallVis   -> addHsTyVarBinds tvs $ \bndrs ->+                   do body1 <- repLTy body+                      repTForallVis bndrs body1+repTy ty@(HsQualTy {}) = repForallT ty++repTy (HsTyVar _ _ (L _ n))+  | isLiftedTypeKindTyConName n       = repTStar+  | n `hasKey` constraintKindTyConKey = repTConstraint+  | n `hasKey` funTyConKey            = repArrowTyCon+  | isTvOcc occ   = do tv1 <- lookupOcc n+                       repTvar tv1+  | isDataOcc occ = do tc1 <- lookupOcc n+                       repPromotedDataCon tc1+  | n == eqTyConName = repTequality+  | otherwise     = do tc1 <- lookupOcc n+                       repNamedTyCon tc1+  where+    occ = nameOccName n++repTy (HsAppTy _ f a)       = do+                                f1 <- repLTy f+                                a1 <- repLTy a+                                repTapp f1 a1+repTy (HsAppKindTy _ ty ki) = do+                                ty1 <- repLTy ty+                                ki1 <- repLTy ki+                                repTappKind ty1 ki1+repTy (HsFunTy _ f a)       = do+                                f1   <- repLTy f+                                a1   <- repLTy a+                                tcon <- repArrowTyCon+                                repTapps tcon [f1, a1]+repTy (HsListTy _ t)        = do+                                t1   <- repLTy t+                                tcon <- repListTyCon+                                repTapp tcon t1+repTy (HsTupleTy _ HsUnboxedTuple tys) = do+                                tys1 <- repLTys tys+                                tcon <- repUnboxedTupleTyCon (length tys)+                                repTapps tcon tys1+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys+                                 tcon <- repTupleTyCon (length tys)+                                 repTapps tcon tys1+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys+                                 tcon <- repUnboxedSumTyCon (length tys)+                                 repTapps tcon tys1+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+                                   `nlHsAppTy` ty2)+repTy (HsParTy _ t)         = repLTy t+repTy (HsStarTy _ _) =  repTStar+repTy (HsKindSig _ t k)     = do+                                t1 <- repLTy t+                                k1 <- repLTy k+                                repTSig t1 k1+repTy (HsSpliceTy _ splice)      = repSplice splice+repTy (HsExplicitListTy _ _ tys) = do+                                    tys1 <- repLTys tys+                                    repTPromotedList tys1+repTy (HsExplicitTupleTy _ tys) = do+                                    tys1 <- repLTys tys+                                    tcon <- repPromotedTupleTyCon (length tys)+                                    repTapps tcon tys1+repTy (HsTyLit _ lit) = do+                          lit' <- repTyLit lit+                          repTLit lit'+repTy (HsWildCardTy _) = repTWildCard+repTy (HsIParamTy _ n t) = do+                             n' <- rep_implicit_param_name (unLoc n)+                             t' <- repLTy t+                             repTImplicitParam n' t'++repTy ty                      = notHandled "Exotic form of type" (ppr ty)++repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i+                            rep2 numTyLitName [iExpr]+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s+                            ; rep2 strTyLitName [s']+                            }++-- | Represent a type wrapped in a Maybe+repMaybeLTy :: Maybe (LHsKind GhcRn)+            -> MetaM (Core (Maybe (M TH.Type)))+repMaybeLTy m = do+  k_ty <- wrapName kindTyConName+  repMaybeT k_ty repLTy m++repRole :: Located (Maybe Role) -> MetaM (Core TH.Role)+repRole (L _ (Just Nominal))          = rep2_nw nominalRName []+repRole (L _ (Just Representational)) = rep2_nw representationalRName []+repRole (L _ (Just Phantom))          = rep2_nw phantomRName []+repRole (L _ Nothing)                 = rep2_nw inferRName []++-----------------------------------------------------------------------------+--              Splices+-----------------------------------------------------------------------------++repSplice :: HsSplice GhcRn -> MetaM (Core a)+-- See Note [How brackets and nested splices are handled] in TcSplice+-- We return a CoreExpr of any old type; the context should know+repSplice (HsTypedSplice   _ _ n _) = rep_splice n+repSplice (HsUntypedSplice _ _ n _) = rep_splice n+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)+repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)+repSplice (XSplice nec)             = noExtCon nec++rep_splice :: Name -> MetaM (Core a)+rep_splice splice_name+ = do { mb_val <- lift $ dsLookupMetaEnv splice_name+       ; case mb_val of+           Just (DsSplice e) -> do { e' <- lift $ dsExpr e+                                   ; return (MkC e') }+           _ -> pprPanic "HsSplice" (ppr splice_name) }+                        -- Should not happen; statically checked++-----------------------------------------------------------------------------+--              Expressions+-----------------------------------------------------------------------------++repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])+repLEs es = repListM expTyConName repLE es++-- FIXME: some of these panics should be converted into proper error messages+--        unless we can make sure that constructs, which are plainly not+--        supported in TH already lead to error messages at an earlier stage+repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))+repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e)++repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))+repE (HsVar _ (L _ x)) =+  do { mb_val <- lift $ dsLookupMetaEnv x+     ; case mb_val of+        Nothing            -> do { str <- lift $ globalVar x+                                 ; repVarOrCon x str }+        Just (DsBound y)   -> repVarOrCon x (coreVar y)+        Just (DsSplice e)  -> do { e' <- lift $ dsExpr e+                                 ; return (MkC e') } }+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar+repE (HsOverLabel _ _ s) = repOverLabel s++repE e@(HsRecFld _ f) = case f of+  Unambiguous x _ -> repE (HsVar noExtField (noLoc x))+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)+  XAmbiguousFieldOcc nec -> noExtCon nec++        -- Remember, we're desugaring renamer output here, so+        -- HsOverlit can definitely occur+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }+repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }+repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m+repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))+                   = do { ms' <- mapM repMatchTup ms+                        ; core_ms <- coreListM matchTyConName ms'+                        ; repLamCase core_ms }+repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}+repE (HsAppType _ e t) = do { a <- repLE e+                            ; s <- repLTy (hswc_body t)+                            ; repAppType a s }++repE (OpApp _ e1 op e2) =+  do { arg1 <- repLE e1;+       arg2 <- repLE e2;+       the_op <- repLE op ;+       repInfixApp arg1 the_op arg2 }+repE (NegApp _ x _)      = do+                              a         <- repLE x+                              negateVar <- lookupOcc negateName >>= repVar+                              negateVar `repApp` a+repE (HsPar _ x)            = repLE x+repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }+repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }+repE (HsCase _ e (MG { mg_alts = (L _ ms) }))+                          = do { arg <- repLE e+                               ; ms2 <- mapM repMatchTup ms+                               ; core_ms2 <- coreListM matchTyConName ms2+                               ; repCaseE arg core_ms2 }+repE (HsIf _ _ x y z)       = do+                              a <- repLE x+                              b <- repLE y+                              c <- repLE z+                              repCond a b c+repE (HsMultiIf _ alts)+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts+       ; expr' <- repMultiIf (nonEmptyCoreList alts')+       ; wrapGenSyms (concat binds) expr' }+repE (HsLet _ (L _ bs) e)       = do { (ss,ds) <- repBinds bs+                                     ; e2 <- addBinds ss (repLE e)+                                     ; z <- repLetE ds e2+                                     ; wrapGenSyms ss z }++-- FIXME: I haven't got the types here right yet+repE e@(HsDo _ ctxt (L _ sts))+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }+ = do { (ss,zs) <- repLSts sts;+        e'      <- repDoE (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++ | ListComp <- ctxt+ = do { (ss,zs) <- repLSts sts;+        e'      <- repComp (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++ | MDoExpr <- ctxt+ = do { (ss,zs) <- repLSts sts;+        e'      <- repMDoE (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++  | otherwise+  = notHandled "monad comprehension and [: :]" (ppr e)++repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }+repE (ExplicitTuple _ es boxity) =+  let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))+      tupArgToCoreExp (L _ a)+        | (Present _ e) <- a = do { e' <- repLE e+                                  ; coreJustM expTyConName e' }+        | otherwise = coreNothingM expTyConName++  in do { args <- mapM tupArgToCoreExp es+        ; expTy <- wrapName  expTyConName+        ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy]+              listArg = coreList' maybeExpQTy args+        ; if isBoxed boxity+          then repTup listArg+          else repUnboxedTup listArg }++repE (ExplicitSum _ alt arity e)+ = do { e1 <- repLE e+      ; repUnboxedSum e1 alt arity }++repE (RecordCon { rcon_con_name = c, rcon_flds = flds })+ = do { x <- lookupLOcc c;+        fs <- repFields flds;+        repRecCon x fs }+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })+ = do { x <- repLE e;+        fs <- repUpdFields flds;+        repRecUpd x fs }++repE (ExprWithTySig _ e ty)+  = do { e1 <- repLE e+       ; t1 <- repHsSigWcType ty+       ; repSigExp e1 t1 }++repE (ArithSeq _ _ aseq) =+  case aseq of+    From e              -> do { ds1 <- repLE e; repFrom ds1 }+    FromThen e1 e2      -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             repFromThen ds1 ds2+    FromTo   e1 e2      -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             repFromTo ds1 ds2+    FromThenTo e1 e2 e3 -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             ds3 <- repLE e3+                             repFromThenTo ds1 ds2 ds3++repE (HsSpliceE _ splice)  = repSplice splice+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC+repE (HsUnboundVar _ uv)   = do+                               occ   <- occNameLit uv+                               sname <- repNameS occ+                               repUnboundVar sname++repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)+repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)+repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)+repE (XExpr nec)           = noExtCon nec+repE e                     = notHandled "Expression form" (ppr e)++-----------------------------------------------------------------------------+-- Building representations of auxiliary structures like Match, Clause, Stmt,++repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))+repMatchTup (L _ (Match { m_pats = [p]+                        , m_grhss = GRHSs _ guards (L _ wheres) })) =+  do { ss1 <- mkGenSyms (collectPatBinders p)+     ; addBinds ss1 $ do {+     ; p1 <- repLP p+     ; (ss2,ds) <- repBinds wheres+     ; addBinds ss2 $ do {+     ; gs    <- repGuards guards+     ; match <- repMatch p1 gs ds+     ; wrapGenSyms (ss1++ss2) match }}}+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"++repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))+repClauseTup (L _ (Match { m_pats = ps+                         , m_grhss = GRHSs _ guards (L _ wheres) })) =+  do { ss1 <- mkGenSyms (collectPatsBinders ps)+     ; addBinds ss1 $ do {+       ps1 <- repLPs ps+     ; (ss2,ds) <- repBinds wheres+     ; addBinds ss2 $ do {+       gs <- repGuards guards+     ; clause <- repClause ps1 gs ds+     ; wrapGenSyms (ss1++ss2) clause }}}+repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec+repClauseTup (L _ (XMatch nec)) = noExtCon nec++repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  MetaM (Core (M TH.Body))+repGuards [L _ (GRHS _ [] e)]+  = do {a <- repLE e; repNormal a }+repGuards other+  = do { zs <- mapM repLGRHS other+       ; let (xs, ys) = unzip zs+       ; gd <- repGuarded (nonEmptyCoreList ys)+       ; wrapGenSyms (concat xs) gd }++repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)+         -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp))))+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))+  = do { guarded <- repLNormalGE e1 e2+       ; return ([], guarded) }+repLGRHS (L _ (GRHS _ ss rhs))+  = do { (gs, ss') <- repLSts ss+       ; rhs' <- addBinds gs $ repLE rhs+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'+       ; return (gs, guarded) }+repLGRHS (L _ (XGRHS nec)) = noExtCon nec++repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])+repFields (HsRecFields { rec_flds = flds })+  = repListM fieldExpTyConName rep_fld flds+  where+    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)+            -> MetaM (Core (M TH.FieldExp))+    rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)+                           ; e  <- repLE (hsRecFieldArg fld)+                           ; repFieldExp fn e }++repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp])+repUpdFields = repListM fieldExpTyConName rep_fld+  where+    rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))+    rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)+                                   ; e  <- repLE (hsRecFieldArg fld)+                                   ; repFieldExp fn e }+      Ambiguous{}            -> notHandled "Ambiguous record updates" (ppr fld)+      XAmbiguousFieldOcc nec -> noExtCon nec++++-----------------------------------------------------------------------------+-- Representing Stmt's is tricky, especially if bound variables+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]+-- First gensym new names for every variable in any of the patterns.+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))+-- if variables didn't shadow, the static gensym wouldn't be necessary+-- and we could reuse the original names (x and x).+--+-- do { x'1 <- gensym "x"+--    ; x'2 <- gensym "x"+--    ; doE [ BindSt (pvar x'1) [| f 1 |]+--          , BindSt (pvar x'2) [| f x |]+--          , NoBindSt [| g x |]+--          ]+--    }++-- The strategy is to translate a whole list of do-bindings by building a+-- bigger environment, and a bigger set of meta bindings+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations+-- of the expressions within the Do++-----------------------------------------------------------------------------+-- The helper function repSts computes the translation of each sub expression+-- and a bunch of prefix bindings denoting the dynamic renaming.++repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])+repLSts stmts = repSts (map unLoc stmts)++repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])+repSts (BindStmt _ p e _ _ : ss) =+   do { e2 <- repLE e+      ; ss1 <- mkGenSyms (collectPatBinders p)+      ; addBinds ss1 $ do {+      ; p1 <- repLP p;+      ; (ss2,zs) <- repSts ss+      ; z <- repBindSt p1 e2+      ; return (ss1++ss2, z : zs) }}+repSts (LetStmt _ (L _ bs) : ss) =+   do { (ss1,ds) <- repBinds bs+      ; z <- repLetSt ds+      ; (ss2,zs) <- addBinds ss1 (repSts ss)+      ; return (ss1++ss2, z : zs) }+repSts (BodyStmt _ e _ _ : ss) =+   do { e2 <- repLE e+      ; z <- repNoBindSt e2+      ; (ss2,zs) <- repSts ss+      ; return (ss2, z : zs) }+repSts (ParStmt _ stmt_blocks _ _ : ss) =+   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks+      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1+            ss1 = concat ss_s+      ; z <- repParSt stmt_blocks2+      ; (ss2, zs) <- addBinds ss1 (repSts ss)+      ; return (ss1++ss2, z : zs) }+   where+     rep_stmt_block :: ParStmtBlock GhcRn GhcRn+                    -> MetaM ([GenSymBind], Core [(M TH.Stmt)])+     rep_stmt_block (ParStmtBlock _ stmts _ _) =+       do { (ss1, zs) <- repSts (map unLoc stmts)+          ; zs1 <- coreListM stmtTyConName zs+          ; return (ss1, zs1) }+     rep_stmt_block (XParStmtBlock nec) = noExtCon nec+repSts [LastStmt _ e _ _]+  = do { e2 <- repLE e+       ; z <- repNoBindSt e2+       ; return ([], [z]) }+repSts (stmt@RecStmt{} : ss)+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)+       ; ss1 <- mkGenSyms binders+       -- Bring all of binders in the recursive group into scope for the+       -- whole group.+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))+       ; MASSERT(sort ss1 == sort ss1_other)+       ; z <- repRecSt (nonEmptyCoreList rss)+       ; (ss2,zs) <- addBinds ss1 (repSts ss)+       ; return (ss1++ss2, z : zs) }+repSts (XStmtLR nec : _) = noExtCon nec+repSts []    = return ([],[])+repSts other = notHandled "Exotic statement" (ppr other)+++-----------------------------------------------------------+--                      Bindings+-----------------------------------------------------------++repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)])+repBinds (EmptyLocalBinds _)+  = do  { core_list <- coreListM decTyConName []+        ; return ([], core_list) }++repBinds (HsIPBinds _ (IPBinds _ decs))+ = do   { ips <- mapM rep_implicit_param_bind decs+        ; core_list <- coreListM decTyConName+                                (de_loc (sort_by_loc ips))+        ; return ([], core_list)+        }++repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec++repBinds (HsValBinds _ decs)+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }+                -- No need to worry about detailed scopes within+                -- the binding group, because we are talking Names+                -- here, so we can safely treat it as a mutually+                -- recursive group+                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]+        ; ss        <- mkGenSyms bndrs+        ; prs       <- addBinds ss (rep_val_binds decs)+        ; core_list <- coreListM decTyConName+                                (de_loc (sort_by_loc prs))+        ; return (ss, core_list) }+repBinds (XHsLocalBindsLR nec) = noExtCon nec++rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))+ = do { name <- case ename of+                    Left (L _ n) -> rep_implicit_param_name n+                    Right _ ->+                        panic "rep_implicit_param_bind: post typechecking"+      ; rhs' <- repE rhs+      ; ipb <- repImplicitParamBind name rhs'+      ; return (loc, ipb) }+rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec++rep_implicit_param_name :: HsIPName -> MetaM (Core String)+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)++rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]+-- Assumes: all the binders of the binding are already in the meta-env+rep_val_binds (XValBindsLR (NValBinds binds sigs))+ = do { core1 <- rep_binds (unionManyBags (map snd binds))+      ; core2 <- rep_sigs sigs+      ; return (core1 ++ core2) }+rep_val_binds (ValBinds _ _ _)+ = panic "rep_val_binds: ValBinds"++rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]+rep_binds = mapM rep_bind . bagToList++rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))+-- Assumes: all the binders of the binding are already in the meta-env++-- Note GHC treats declarations of a variable (not a pattern)+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match+-- with an empty list of patterns+rep_bind (L loc (FunBind+                 { fun_id = fn,+                   fun_matches = MG { mg_alts+                           = (L _ [L _ (Match+                                   { m_pats = []+                                   , m_grhss = GRHSs _ guards (L _ wheres) }+                                      )]) } }))+ = do { (ss,wherecore) <- repBinds wheres+        ; guardcore <- addBinds ss (repGuards guards)+        ; fn'  <- lookupLBinder fn+        ; p    <- repPvar fn'+        ; ans  <- repVal p guardcore wherecore+        ; ans' <- wrapGenSyms ss ans+        ; return (loc, ans') }++rep_bind (L loc (FunBind { fun_id = fn+                         , fun_matches = MG { mg_alts = L _ ms } }))+ =   do { ms1 <- mapM repClauseTup ms+        ; fn' <- lookupLBinder fn+        ; ans <- repFun fn' (nonEmptyCoreList ms1)+        ; return (loc, ans) }++rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec++rep_bind (L loc (PatBind { pat_lhs = pat+                         , pat_rhs = GRHSs _ guards (L _ wheres) }))+ =   do { patcore <- repLP pat+        ; (ss,wherecore) <- repBinds wheres+        ; guardcore <- addBinds ss (repGuards guards)+        ; ans  <- repVal patcore guardcore wherecore+        ; ans' <- wrapGenSyms ss ans+        ; return (loc, ans') }+rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec++rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))+ =   do { v' <- lookupBinder v+        ; e2 <- repLE e+        ; x <- repNormal e2+        ; patcore <- repPvar v'+        ; empty_decls <- coreListM decTyConName []+        ; ans <- repVal patcore x empty_decls+        ; return (srcLocSpan (getSrcLoc v), ans) }++rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"+rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn+                                   , psb_args = args+                                   , psb_def  = pat+                                   , psb_dir  = dir })))+  = do { syn'      <- lookupLBinder syn+       ; dir'      <- repPatSynDir dir+       ; ss        <- mkGenArgSyms args+       ; patSynD'  <- addBinds ss (+         do { args'  <- repPatSynArgs args+            ; pat'   <- repLP pat+            ; repPatSynD syn' args' dir' pat' })+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'+       ; return (loc, patSynD'') }+  where+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]+    -- for Record Pattern Synonyms we want to conflate the selector+    -- and the pattern-only names in order to provide a nicer TH+    -- API. Whereas inside GHC, record pattern synonym selectors and+    -- their pattern-only bound right hand sides have different names,+    -- we want to treat them the same in TH. This is the reason why we+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]+    mkGenArgSyms (RecCon fields)+      = do { let pats = map (unLoc . recordPatSynPatVar) fields+                 sels = map (unLoc . recordPatSynSelectorId) fields+           ; ss <- mkGenSyms sels+           ; return $ replaceNames (zip sels pats) ss }++    replaceNames selsPats genSyms+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats+                    , sel == sel' ]++    wrapGenArgSyms :: HsPatSynDetails (Located Name)+                   -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))+    wrapGenArgSyms (RecCon _) _  dec = return dec+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec++rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec+rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec++repPatSynD :: Core TH.Name+           -> Core (M TH.PatSynArgs)+           -> Core (M TH.PatSynDir)+           -> Core (M TH.Pat)+           -> MetaM (Core (M TH.Dec))+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)+  = rep2 patSynDName [syn, args, dir, pat]++repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))+repPatSynArgs (PrefixCon args)+  = do { args' <- repList nameTyConName lookupLOcc args+       ; repPrefixPatSynArgs args' }+repPatSynArgs (InfixCon arg1 arg2)+  = do { arg1' <- lookupLOcc arg1+       ; arg2' <- lookupLOcc arg2+       ; repInfixPatSynArgs arg1' arg2' }+repPatSynArgs (RecCon fields)+  = do { sels' <- repList nameTyConName lookupLOcc sels+       ; repRecordPatSynArgs sels' }+  where sels = map recordPatSynSelectorId fields++repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs))+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]++repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs))+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]++repRecordPatSynArgs :: Core [TH.Name]+                    -> MetaM (Core (M TH.PatSynArgs))+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]++repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir))+repPatSynDir Unidirectional        = rep2 unidirPatSynName []+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))+  = do { clauses' <- mapM repClauseTup clauses+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }+repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec++repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]+++-----------------------------------------------------------------------------+-- Since everything in a Bind is mutually recursive we need rename all+-- all the variables simultaneously. For example:+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to+-- do { f'1 <- gensym "f"+--    ; g'2 <- gensym "g"+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}+--      ]}+-- This requires collecting the bindings (f'1 <- gensym "f"), and the+-- environment ( f |-> f'1 ) from each binding, and then unioning them+-- together. As we do this we collect GenSymBinds's which represent the renamed+-- variables bound by the Bindings. In order not to lose track of these+-- representations we build a shadow datatype MB with the same structure as+-- MonoBinds, but which has slots for the representations+++-----------------------------------------------------------------------------+-- GHC allows a more general form of lambda abstraction than specified+-- by Haskell 98. In particular it allows guarded lambda's like :+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like+-- (\ p1 .. pn -> exp) by causing an error.++repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))+repLambda (L _ (Match { m_pats = ps+                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]+                                              (L _ (EmptyLocalBinds _)) } ))+ = do { let bndrs = collectPatsBinders ps ;+      ; ss  <- mkGenSyms bndrs+      ; lam <- addBinds ss (+                do { xs <- repLPs ps; body <- repLE e; repLam xs body })+      ; wrapGenSyms ss lam }+repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]+                                          (L _ (XHsLocalBindsLR nec)) } ))+ = noExtCon nec++repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)+++-----------------------------------------------------------------------------+--                      Patterns+-- repP deals with patterns.  It assumes that we have already+-- walked over the pattern(s) once to collect the binders, and+-- have extended the environment.  So every pattern-bound+-- variable should already appear in the environment.++-- Process a list of patterns+repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])+repLPs ps = repListM patTyConName repLP ps++repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))+repLP p = repP (unLoc p)++repP :: Pat GhcRn -> MetaM (Core (M TH.Pat))+repP (WildPat _)        = repPwild+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }+repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p+                             ; repPaspat x' p1 }+repP (ParPat _ p)       = repLP p+repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }+repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)+                                ; e' <- repE (syn_expr e)+                                ; repPview e' p}+repP (TuplePat _ ps boxed)+  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }+  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }+repP (SumPat _ p alt arity) = do { p1 <- repLP p+                                 ; repPunboxedSum p1 alt arity }+repP (ConPatIn dc details)+ = do { con_str <- lookupLOcc dc+      ; case details of+         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }+         RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)+                            ; repPrec con_str fps }+         InfixCon p1 p2 -> do { p1' <- repLP p1;+                                p2' <- repLP p2;+                                repPinfix p1' con_str p2' }+   }+ where+   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))+   rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)+                          ; MkC p <- repLP (hsRecFieldArg fld)+                          ; rep2 fieldPatName [v,p] }++repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l+                                     ; repPlit a }+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)+repP (SigPat _ p t) = do { p' <- repLP p+                         ; t' <- repLTy (hsSigWcType t)+                         ; repPsig p' t' }+repP (SplicePat _ splice) = repSplice splice+repP (XPat nec) = noExtCon nec+repP other = notHandled "Exotic pattern" (ppr other)++----------------------------------------------------------+-- Declaration ordering helpers++sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]+sort_by_loc xs = sortBy comp xs+    where comp x y = compare (fst x) (fst y)++de_loc :: [(a, b)] -> [b]+de_loc = map snd++----------------------------------------------------------+--      The meta-environment++-- A name/identifier association for fresh names of locally bound entities+type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id+                                -- I.e.         (x, x_id) means+                                --      let x_id = gensym "x" in ...++-- Generate a fresh name for a locally bound entity++mkGenSyms :: [Name] -> MetaM [GenSymBind]+-- We can use the existing name.  For example:+--      [| \x_77 -> x_77 + x_77 |]+-- desugars to+--      do { x_77 <- genSym "x"; .... }+-- We use the same x_77 in the desugared program, but with the type Bndr+-- instead of Int+--+-- We do make it an Internal name, though (hence localiseName)+--+-- Nevertheless, it's monadic because we have to generate nameTy+mkGenSyms ns = do { var_ty <- lookupType nameTyConName+                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }+++addBinds :: [GenSymBind] -> MetaM a -> MetaM a+-- Add a list of fresh names for locally bound entities to the+-- meta environment (which is part of the state carried around+-- by the desugarer monad)+addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m++-- Look up a locally bound name+--+lookupLBinder :: Located Name -> MetaM (Core TH.Name)+lookupLBinder n = lookupBinder (unLoc n)++lookupBinder :: Name -> MetaM (Core TH.Name)+lookupBinder = lookupOcc+  -- Binders are brought into scope before the pattern or what-not is+  -- desugared.  Moreover, in instance declaration the binder of a method+  -- will be the selector Id and hence a global; so we need the+  -- globalVar case of lookupOcc++-- Look up a name that is either locally bound or a global name+--+--  * If it is a global name, generate the "original name" representation (ie,+--   the <module>:<name> form) for the associated entity+--+lookupLOcc :: Located Name -> MetaM (Core TH.Name)+-- Lookup an occurrence; it can't be a splice.+-- Use the in-scope bindings if they exist+lookupLOcc n = lookupOcc (unLoc n)++lookupOcc :: Name -> MetaM (Core TH.Name)+lookupOcc = lift . lookupOccDsM++lookupOccDsM :: Name -> DsM (Core TH.Name)+lookupOccDsM n+  = do {  mb_val <- dsLookupMetaEnv n ;+          case mb_val of+                Nothing           -> globalVar n+                Just (DsBound x)  -> return (coreVar x)+                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)+    }++globalVar :: Name -> DsM (Core TH.Name)+-- Not bound by the meta-env+-- Could be top-level; or could be local+--      f x = $(g [| x |])+-- Here the x will be local+globalVar name+  | isExternalName name+  = do  { MkC mod <- coreStringLit name_mod+        ; MkC pkg <- coreStringLit name_pkg+        ; MkC occ <- nameLit name+        ; rep2_nwDsM mk_varg [pkg,mod,occ] }+  | otherwise+  = do  { MkC occ <- nameLit name+        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))+        ; rep2_nwDsM mkNameLName [occ,uni] }+  where+      mod = ASSERT( isExternalName name) nameModule name+      name_mod = moduleNameString (moduleName mod)+      name_pkg = unitIdString (moduleUnitId mod)+      name_occ = nameOccName name+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName+              | OccName.isVarOcc  name_occ = mkNameG_vName+              | OccName.isTcOcc   name_occ = mkNameG_tcName+              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)++lookupType :: Name      -- Name of type constructor (e.g. (M TH.Exp))+           -> MetaM Type  -- The type+lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;+                          return (mkTyConApp tc []) }++wrapGenSyms :: [GenSymBind]+            -> Core (M a) -> MetaM (Core (M a))+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y+--      --> bindQ (gensym nm1) (\ id1 ->+--          bindQ (gensym nm2 (\ id2 ->+--          y))++wrapGenSyms binds body@(MkC b)+  = do  { var_ty <- lookupType nameTyConName+        ; go var_ty binds }+  where+    (_, [elt_ty]) = tcSplitAppTys (exprType b)+        -- b :: m a, so we can get the type 'a' by looking at the+        -- argument type. NB: this relies on Q being a data/newtype,+        -- not a type synonym++    go _ [] = return body+    go var_ty ((name,id) : binds)+      = do { MkC body'  <- go var_ty binds+           ; lit_str    <- lift $ nameLit name+           ; gensym_app <- repGensym lit_str+           ; repBindM var_ty elt_ty+                      gensym_app (MkC (Lam id body')) }++nameLit :: Name -> DsM (Core String)+nameLit n = coreStringLit (occNameString (nameOccName n))++occNameLit :: OccName -> MetaM (Core String)+occNameLit name = coreStringLit (occNameString name)+++-- %*********************************************************************+-- %*                                                                   *+--              Constructing code+-- %*                                                                   *+-- %*********************************************************************++-----------------------------------------------------------------------------+-- PHANTOM TYPES for consistency. In order to make sure we do this correct+-- we invent a new datatype which uses phantom types.++newtype Core a = MkC CoreExpr+unC :: Core a -> CoreExpr+unC (MkC x) = x++type family NotM a where+  NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type"))+  NotM _other = (() :: Constraint)++rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a))+rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a))+rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a)+rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a)+rep2 = rep2X lift (asks quoteWrapper)+rep2M = rep2X lift (asks monadWrapper)+rep2_nw n xs = lift (rep2_nwDsM n xs)+rep2_nwDsM = rep2X id (return id)++rep2X :: Monad m => (forall z . DsM z -> m z)+      -> m (CoreExpr -> CoreExpr)+      -> Name+      -> [ CoreExpr ]+      -> m (Core a)+rep2X lift_dsm get_wrap n xs = do+  { rep_id <- lift_dsm $ dsLookupGlobalId n+  ; wrap <- get_wrap+  ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) }+++dataCon' :: Name -> [CoreExpr] -> MetaM (Core a)+dataCon' n args = do { id <- lift $ dsLookupDataCon n+                     ; return $ MkC $ mkCoreConApps id args }++dataCon :: Name -> MetaM (Core a)+dataCon n = dataCon' n []+++-- %*********************************************************************+-- %*                                                                   *+--              The 'smart constructors'+-- %*                                                                   *+-- %*********************************************************************++--------------- Patterns -----------------+repPlit   :: Core TH.Lit -> MetaM (Core (M TH.Pat))+repPlit (MkC l) = rep2 litPName [l]++repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat))+repPvar (MkC s) = rep2 varPName [s]++repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))+repPtup (MkC ps) = rep2 tupPName [ps]++repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]++repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat))+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here+repPunboxedSum (MkC p) alt arity+ = do { dflags <- getDynFlags+      ; rep2 unboxedSumPName [ p+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags arity ] }++repPcon   :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]++repPrec   :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]++repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]++repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))+repPtilde (MkC p) = rep2 tildePName [p]++repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))+repPbang (MkC p) = rep2 bangPName [p]++repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]++repPwild  :: MetaM (Core (M TH.Pat))+repPwild = rep2 wildPName []++repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))+repPlist (MkC ps) = rep2 listPName [ps]++repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]++repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]++--------------- Expressions -----------------+repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str+                   | otherwise                  = repVar str++repVar :: Core TH.Name -> MetaM (Core (M TH.Exp))+repVar (MkC s) = rep2 varEName [s]++repCon :: Core TH.Name -> MetaM (Core (M TH.Exp))+repCon (MkC s) = rep2 conEName [s]++repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp))+repLit (MkC c) = rep2 litEName [c]++repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repApp (MkC x) (MkC y) = rep2 appEName [x,y]++repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]++repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]++repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))+repLamCase (MkC ms) = rep2 lamCaseEName [ms]++repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))+repTup (MkC es) = rep2 tupEName [es]++repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]++repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp))+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here+repUnboxedSum (MkC e) alt arity+ = do { dflags <- getDynFlags+      ; rep2 unboxedSumEName [ e+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags arity ] }++repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]++repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp))+repMultiIf (MkC alts) = rep2 multiIfEName [alts]++repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]++repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]++repDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repDoE (MkC ss) = rep2 doEName [ss]++repMDoE :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repMDoE (MkC ss) = rep2 mdoEName [ss]++repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))+repComp (MkC ss) = rep2 compEName [ss]++repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp))+repListExp (MkC es) = rep2 listEName [es]++repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]++repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]++repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]++repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp))+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]++repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]++repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]++repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]++repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp))+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]++------------ Right hand sides (guarded expressions) ----+repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body))+repGuarded (MkC pairs) = rep2 guardedBName [pairs]++repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body))+repNormal (MkC e) = rep2 normalBName [e]++------------ Guards ----+repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn+             -> MetaM (Core (M (TH.Guard, TH.Exp)))+repLNormalGE g e = do g' <- repLE g+                      e' <- repLE e+                      repNormalGE g' e'++repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]++repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]++------------- Stmts -------------------+repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]++repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt))+repLetSt (MkC ds) = rep2 letSName [ds]++repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))+repNoBindSt (MkC e) = rep2 noBindSName [e]++repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt))+repParSt (MkC sss) = rep2 parSName [sss]++repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt))+repRecSt (MkC ss) = rep2 recSName [ss]++-------------- Range (Arithmetic sequences) -----------+repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repFrom (MkC x) = rep2 fromEName [x]++repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]++repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]++repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]++------------ Match and Clause Tuples -----------+repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]++repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]++-------------- Dec -----------------------------+repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]++repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]++repData :: Core (M TH.Cxt) -> Core TH.Name+        -> Either (Core [(M TH.TyVarBndr)])+                  (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))+        -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]+        -> MetaM (Core (M TH.Dec))+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]+repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)+        (MkC derivs)+  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]++repNewtype :: Core (M TH.Cxt) -> Core TH.Name+           -> Either (Core [(M TH.TyVarBndr)])+                     (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type))+           -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]+           -> MetaM (Core (M TH.Dec))+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)+           (MkC derivs)+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]+repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)+           (MkC derivs)+  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]++repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)]+         -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))+repTySyn (MkC nm) (MkC tvs) (MkC rhs)+  = rep2 tySynDName [nm, tvs, rhs]++repInst :: Core (Maybe TH.Overlap) ->+           Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName+                                                              [o, cxt, ty, ds]++repDerivStrategy :: Maybe (LDerivStrategy GhcRn)+                 -> MetaM (Core (Maybe (M TH.DerivStrategy)))+repDerivStrategy mds =+  case mds of+    Nothing -> nothing+    Just ds ->+      case unLoc ds of+        StockStrategy    -> just =<< repStockStrategy+        AnyclassStrategy -> just =<< repAnyclassStrategy+        NewtypeStrategy  -> just =<< repNewtypeStrategy+        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)+                               via_strat <- repViaStrategy ty'+                               just via_strat+  where+  nothing = coreNothingM derivStrategyTyConName+  just    = coreJustM    derivStrategyTyConName++repStockStrategy :: MetaM (Core (M TH.DerivStrategy))+repStockStrategy = rep2 stockStrategyName []++repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy))+repAnyclassStrategy = rep2 anyclassStrategyName []++repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy))+repNewtypeStrategy = rep2 newtypeStrategyName []++repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy))+repViaStrategy (MkC t) = rep2 viaStrategyName [t]++repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap))+repOverlap mb =+  case mb of+    Nothing -> nothing+    Just o ->+      case o of+        NoOverlap _    -> nothing+        Overlappable _ -> just =<< dataCon overlappableDataConName+        Overlapping _  -> just =<< dataCon overlappingDataConName+        Overlaps _     -> just =<< dataCon overlapsDataConName+        Incoherent _   -> just =<< dataCon incoherentDataConName+  where+  nothing = coreNothing overlapTyConName+  just    = coreJust overlapTyConName+++repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)]+         -> Core [TH.FunDep] -> Core [(M TH.Dec)]+         -> MetaM (Core (M TH.Dec))+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)+  = rep2 classDName [cxt, cls, tvs, fds, ds]++repDeriv :: Core (Maybe (M TH.DerivStrategy))+         -> Core (M TH.Cxt) -> Core (M TH.Type)+         -> MetaM (Core (M TH.Dec))+repDeriv (MkC ds) (MkC cxt) (MkC ty)+  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]++repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch+           -> Core TH.Phases -> MetaM (Core (M TH.Dec))+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)+  = rep2 pragInlDName [nm, inline, rm, phases]++repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases+            -> MetaM (Core (M TH.Dec))+repPragSpec (MkC nm) (MkC ty) (MkC phases)+  = rep2 pragSpecDName [nm, ty, phases]++repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline+               -> Core TH.Phases -> MetaM (Core (M TH.Dec))+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)+  = rep2 pragSpecInlDName [nm, ty, inline, phases]++repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]++repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]++repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)])+            -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp)+            -> Core TH.Phases -> MetaM (Core (M TH.Dec))+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)+  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]++repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]++repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))+repTySynInst (MkC eqn)+    = rep2 tySynInstDName [eqn]++repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)]+               -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)+    = rep2 dataFamilyDName [nm, tvs, kind]++repOpenFamilyD :: Core TH.Name+               -> Core [(M TH.TyVarBndr)]+               -> Core (M TH.FamilyResultSig)+               -> Core (Maybe TH.InjectivityAnn)+               -> MetaM (Core (M TH.Dec))+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)+    = rep2 openTypeFamilyDName [nm, tvs, result, inj]++repClosedFamilyD :: Core TH.Name+                 -> Core [(M TH.TyVarBndr)]+                 -> Core (M TH.FamilyResultSig)+                 -> Core (Maybe TH.InjectivityAnn)+                 -> Core [(M TH.TySynEqn)]+                 -> MetaM (Core (M TH.Dec))+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)+    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]++repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) ->+               Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn))+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)+  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]++repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec))+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]++repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep)+repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys]++repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]++repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]++repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))+repCtxt (MkC tys) = rep2 cxtName [tys]++repDataCon :: Located Name+           -> HsConDeclDetails GhcRn+           -> MetaM (Core (M TH.Con))+repDataCon con details+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]+         repConstr details Nothing [con']++repGadtDataCons :: [Located Name]+                -> HsConDeclDetails GhcRn+                -> LHsType GhcRn+                -> MetaM (Core (M TH.Con))+repGadtDataCons cons details res_ty+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]+         repConstr details (Just res_ty) cons'++-- Invariant:+--   * for plain H98 data constructors second argument is Nothing and third+--     argument is a singleton list+--   * for GADTs data constructors second argument is (Just return_type) and+--     third argument is a non-empty list+repConstr :: HsConDeclDetails GhcRn+          -> Maybe (LHsType GhcRn)+          -> [Core TH.Name]+          -> MetaM (Core (M TH.Con))+repConstr (PrefixCon ps) Nothing [con]+    = do arg_tys  <- repListM bangTypeTyConName repBangTy ps+         rep2 normalCName [unC con, unC arg_tys]++repConstr (PrefixCon ps) (Just res_ty) cons+    = do arg_tys     <- repListM bangTypeTyConName repBangTy ps+         res_ty' <- repLTy res_ty+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']++repConstr (RecCon ips) resTy cons+    = do args     <- concatMapM rep_ip (unLoc ips)+         arg_vtys <- coreListM varBangTypeTyConName args+         case resTy of+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]+           Just res_ty -> do+             res_ty' <- repLTy res_ty+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,+                                unC res_ty']++    where+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)++      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)+                          ; MkC ty <- repBangTy  t+                          ; rep2 varBangTypeName [v,ty] }++repConstr (InfixCon st1 st2) Nothing [con]+    = do arg1 <- repBangTy st1+         arg2 <- repBangTy st2+         rep2 infixCName [unC arg1, unC con, unC arg2]++repConstr (InfixCon {}) (Just _) _ =+    panic "repConstr: infix GADT constructor should be in a PrefixCon"+repConstr _ _ _ =+    panic "repConstr: invariant violated"++------------ Types -------------------++repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type)+           -> MetaM (Core (M TH.Type))+repTForall (MkC tvars) (MkC ctxt) (MkC ty)+    = rep2 forallTName [tvars, ctxt, ty]++repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type)+              -> MetaM (Core (M TH.Type))+repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]++repTvar :: Core TH.Name -> MetaM (Core (M TH.Type))+repTvar (MkC s) = rep2 varTName [s]++repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type))+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]++repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))+repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]++repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type))+repTapps f []     = return f+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }++repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]++repTequality :: MetaM (Core (M TH.Type))+repTequality = rep2 equalityTName []++repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type))+repTPromotedList []     = repPromotedNilTyCon+repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon+                              ; f <- repTapp tcon t+                              ; t' <- repTPromotedList ts+                              ; repTapp f t'+                              }++repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type))+repTLit (MkC lit) = rep2 litTName [lit]++repTWildCard :: MetaM (Core (M TH.Type))+repTWildCard = rep2 wildCardTName []++repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type))+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]++repTStar :: MetaM (Core (M TH.Type))+repTStar = rep2 starKName []++repTConstraint :: MetaM (Core (M TH.Type))+repTConstraint = rep2 constraintKName []++--------- Type constructors --------------++repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type))+repNamedTyCon (MkC s) = rep2 conTName [s]++repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type)+             -> MetaM (Core (M TH.Type))+repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]++repTupleTyCon :: Int -> MetaM (Core (M TH.Type))+-- Note: not Core Int; it's easier to be direct here+repTupleTyCon i = do dflags <- getDynFlags+                     rep2 tupleTName [mkIntExprInt dflags i]++repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))+-- Note: not Core Int; it's easier to be direct here+repUnboxedTupleTyCon i = do dflags <- getDynFlags+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]++repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))+-- Note: not Core TH.SumArity; it's easier to be direct here+repUnboxedSumTyCon arity = do dflags <- getDynFlags+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]++repArrowTyCon :: MetaM (Core (M TH.Type))+repArrowTyCon = rep2 arrowTName []++repListTyCon :: MetaM (Core (M TH.Type))+repListTyCon = rep2 listTName []++repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type))+repPromotedDataCon (MkC s) = rep2 promotedTName [s]++repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))+repPromotedTupleTyCon i = do dflags <- getDynFlags+                             rep2 promotedTupleTName [mkIntExprInt dflags i]++repPromotedNilTyCon :: MetaM (Core (M TH.Type))+repPromotedNilTyCon = rep2 promotedNilTName []++repPromotedConsTyCon :: MetaM (Core (M TH.Type))+repPromotedConsTyCon = rep2 promotedConsTName []++------------ TyVarBndrs -------------------++repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr))+repPlainTV (MkC nm) = rep2 plainTVName [nm]++repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr))+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]++----------------------------------------------------------+--       Type family result signature++repNoSig :: MetaM (Core (M TH.FamilyResultSig))+repNoSig = rep2 noSigName []++repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig))+repKindSig (MkC ki) = rep2 kindSigName [ki]++repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig))+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]++----------------------------------------------------------+--              Literals++repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)+repLiteral (HsStringPrim _ bs)+  = do dflags   <- getDynFlags+       word8_ty <- lookupType word8TyConName+       let w8s = unpack bs+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon+                                  [mkWordLit dflags (toInteger w8)]) w8s+       rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]+repLiteral lit+  = do lit' <- case lit of+                   HsIntPrim _ i    -> mk_integer i+                   HsWordPrim _ w   -> mk_integer w+                   HsInt _ i        -> mk_integer (il_value i)+                   HsFloatPrim _ r  -> mk_rational r+                   HsDoublePrim _ r -> mk_rational r+                   HsCharPrim _ c   -> mk_char c+                   _ -> return lit+       lit_expr <- lift $ dsLit lit'+       case mb_lit_name of+          Just lit_name -> rep2_nw lit_name [lit_expr]+          Nothing -> notHandled "Exotic literal" (ppr lit)+  where+    mb_lit_name = case lit of+                 HsInteger _ _ _  -> Just integerLName+                 HsInt _ _        -> Just integerLName+                 HsIntPrim _ _    -> Just intPrimLName+                 HsWordPrim _ _   -> Just wordPrimLName+                 HsFloatPrim _ _  -> Just floatPrimLName+                 HsDoublePrim _ _ -> Just doublePrimLName+                 HsChar _ _       -> Just charLName+                 HsCharPrim _ _   -> Just charPrimLName+                 HsString _ _     -> Just stringLName+                 HsRat _ _ _      -> Just rationalLName+                 _                -> Nothing++mk_integer :: Integer -> MetaM (HsLit GhcRn)+mk_integer  i = do integer_ty <- lookupType integerTyConName+                   return $ HsInteger NoSourceText i integer_ty++mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)+mk_rational r = do rat_ty <- lookupType rationalTyConName+                   return $ HsRat noExtField r rat_ty+mk_string :: FastString -> MetaM (HsLit GhcRn)+mk_string s = return $ HsString NoSourceText s++mk_char :: Char -> MetaM (HsLit GhcRn)+mk_char c = return $ HsChar NoSourceText c++repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)+repOverloadedLiteral (OverLit { ol_val = val})+  = do { lit <- mk_lit val; repLiteral lit }+        -- The type Rational will be in the environment, because+        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,+        -- and rationalL is sucked in when any TH stuff is used+repOverloadedLiteral (XOverLit nec) = noExtCon nec++mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)+mk_lit (HsIntegral i)     = mk_integer  (il_value i)+mk_lit (HsFractional f)   = mk_rational f+mk_lit (HsIsString _ s)   = mk_string   s++repNameS :: Core String -> MetaM (Core TH.Name)+repNameS (MkC name) = rep2_nw mkNameSName [name]++--------------- Miscellaneous -------------------++repGensym :: Core String -> MetaM (Core (M TH.Name))+repGensym (MkC lit_str) = rep2 newNameName [lit_str]++repBindM :: Type -> Type        -- a and b+         -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b))+repBindM ty_a ty_b (MkC x) (MkC y)+  = rep2M bindMName [Type ty_a, Type ty_b, x, y]++repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a]))+repSequenceM ty_a (MkC list)+  = rep2M sequenceQName [Type ty_a, list]++repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp))+repUnboundVar (MkC name) = rep2 unboundVarEName [name]++repOverLabel :: FastString -> MetaM (Core (M TH.Exp))+repOverLabel fs = do+                    (MkC s) <- coreStringLit $ unpackFS fs+                    rep2 labelEName [s]+++------------ Lists -------------------+-- turn a list of patterns into a single pattern matching a list++repList :: Name -> (a  -> MetaM (Core b))+                    -> [a] -> MetaM (Core [b])+repList tc_name f args+  = do { args1 <- mapM f args+       ; coreList tc_name args1 }++-- Create a list of m a values+repListM :: Name -> (a  -> MetaM (Core b))+                    -> [a] -> MetaM (Core [b])+repListM tc_name f args+  = do { ty <- wrapName tc_name+       ; args1 <- mapM f args+       ; return $ coreList' ty args1 }++coreListM :: Name -> [Core a] -> MetaM (Core [a])+coreListM tc as = repListM tc return as++coreList :: Name    -- Of the TyCon of the element type+         -> [Core a] -> MetaM (Core [a])+coreList tc_name es+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }++coreList' :: Type       -- The element type+          -> [Core a] -> Core [a]+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))++nonEmptyCoreList :: [Core a] -> Core [a]+  -- The list must be non-empty so we can get the element type+  -- Otherwise use coreList+nonEmptyCoreList []           = panic "coreList: empty argument"+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))+++coreStringLit :: MonadThings m => String -> m (Core String)+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }++------------------- Maybe ------------------++repMaybe :: Name -> (a -> MetaM (Core b))+                    -> Maybe a -> MetaM (Core (Maybe b))+repMaybe tc_name f m = do+  t <- lookupType tc_name+  repMaybeT t f m++repMaybeT :: Type -> (a -> MetaM (Core b))+                    -> Maybe a -> MetaM (Core (Maybe b))+repMaybeT ty _ Nothing   = return $ coreNothing' ty+repMaybeT ty f (Just es) = coreJust' ty <$> f es++-- | Construct Core expression for Nothing of a given type name+coreNothing :: Name        -- ^ Name of the TyCon of the element type+            -> MetaM (Core (Maybe a))+coreNothing tc_name =+    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }++coreNothingM :: Name -> MetaM (Core (Maybe a))+coreNothingM tc_name =+    do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) }++-- | Construct Core expression for Nothing of a given type+coreNothing' :: Type       -- ^ The element type+             -> Core (Maybe a)+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)++-- | Store given Core expression in a Just of a given type name+coreJust :: Name        -- ^ Name of the TyCon of the element type+         -> Core a -> MetaM (Core (Maybe a))+coreJust tc_name es+  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }++coreJustM :: Name -> Core a -> MetaM (Core (Maybe a))+coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) }++-- | Store given Core expression in a Just of a given type+coreJust' :: Type       -- ^ The element type+          -> Core a -> Core (Maybe a)+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))++------------------- Maybe Lists ------------------++-- Lookup the name and wrap it with the m variable+repMaybeListM :: Name -> (a -> MetaM (Core b))+                        -> Maybe [a] -> MetaM (Core (Maybe [b]))+repMaybeListM tc_name f xs = do+  elt_ty <- wrapName tc_name+  repMaybeListT elt_ty f xs+++repMaybeListT :: Type -> (a -> MetaM (Core b))+                        -> Maybe [a] -> MetaM (Core (Maybe [b]))+repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty+repMaybeListT elt_ty f (Just args)+  = do { args1 <- mapM f args+       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }++coreNothingList :: Type -> MetaM (Core (Maybe [a]))+coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)++------------ Literals & Variables -------------------++coreIntLit :: Int -> MetaM (Core Int)+coreIntLit i = do dflags <- getDynFlags+                  return (MkC (mkIntExprInt dflags i))++coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)+coreIntegerLit i = fmap MkC (mkIntegerExpr i)++coreVar :: Id -> Core TH.Name   -- The Id has type Name+coreVar id = MkC (Var id)++----------------- Failure -----------------------+notHandledL :: SrcSpan -> String -> SDoc -> MetaM a+notHandledL loc what doc+  | isGoodSrcSpan loc+  = mapReaderT (putSrcSpanDs loc) $ notHandled what doc+  | otherwise+  = notHandled what doc++notHandled :: String -> SDoc -> MetaM a+notHandled what doc = lift $ failWithDs msg   where     msg = hang (text what <+> text "not (yet) handled by Template Haskell")              2 doc
compiler/deSugar/DsMonad.hs view
@@ -60,7 +60,7 @@ import MkCore    ( unitExpr ) import CoreUtils ( exprType, isExprLevPoly ) import GHC.Hs-import TcIface+import GHC.IfaceToCore import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames import RdrName
compiler/deSugar/DsUsage.hs view
@@ -2,8 +2,10 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module DsUsage (-    -- * Dependency/fingerprinting code (used by MkIface)+    -- * Dependency/fingerprinting code (used by GHC.Iface.Utils)     mkUsageInfo, mkUsedNames, mkDependencies     ) where @@ -38,7 +40,7 @@ {- Note [Module self-dependency]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -RnNames.calculateAvails asserts the invariant that a module must not occur in+GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in its own dep_orphs or dep_finsts. However, if we aren't careful this can occur in the presence of hs-boot files: Consider that we have two modules, A and B, both with hs-boot files,@@ -88,7 +90,7 @@                | otherwise = raw_pkgs            -- Set the packages required to be Safe according to Safe Haskell.-          -- See Note [RnNames . Tracking Trust Transitively]+          -- See Note [Tracking Trust Transitively] in GHC.Rename.Names           sorted_pkgs = sort (Set.toList pkgs)           trust_pkgs  = imp_trust_pkgs imports           dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
compiler/deSugar/DsUtils.hs view
@@ -84,6 +84,8 @@ import TcEvidence  import Control.Monad    ( zipWithM )+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL  {- ************************************************************************@@ -186,9 +188,9 @@ firstPat :: EquationInfo -> Pat GhcTc firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) -shiftEqns :: [EquationInfo] -> [EquationInfo]+shiftEqns :: Functor f => f EquationInfo -> f EquationInfo -- Drop the first pattern in each equation-shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]+shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }  -- Functions on MatchResults @@ -286,13 +288,13 @@                             alt_result :: MatchResult }  mkCoAlgCaseMatchResult-  :: Id                 -- Scrutinee-  -> Type               -- Type of exp-  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)+  :: Id -- ^ Scrutinee+  -> Type -- ^ Type of exp+  -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)   -> MatchResult mkCoAlgCaseMatchResult var ty match_alts   | isNewtype  -- Newtype case; use a let-  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )+  = ASSERT( null match_alts_tail && null (tail arg_ids1) )     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1    | otherwise@@ -303,8 +305,8 @@         -- [Interesting: because of GADTs, we can't rely on the type of         --  the scrutinised Id to be sufficiently refined to have a TyCon in it] -    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }-      = ASSERT( notNull match_alts ) head match_alts+    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail+      = match_alts     -- Stuff for newtype     arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1     var_ty        = idType var@@ -315,9 +317,6 @@ mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt -sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]-sort_alts = sortWith (dataConTag . alt_pat)- mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do     matcher <- dsLExpr $ mkLHsWrap wrapper $@@ -337,17 +336,16 @@     ensure_unstrict cont | needs_void_lam = Lam voidArgId cont                          | otherwise      = cont -mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult-mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"-mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case+mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult+mkDataConCase var ty alts@(alt1 :| _) = MatchResult fail_flag mk_case   where     con1          = alt_pat alt1     tycon         = dataConTyCon con1     data_cons     = tyConDataCons tycon-    match_results = map alt_result alts+    match_results = fmap alt_result alts -    sorted_alts :: [CaseAlt DataCon]-    sorted_alts  = sort_alts alts+    sorted_alts :: NonEmpty (CaseAlt DataCon)+    sorted_alts  = NEL.sortWith (dataConTag . alt_pat) alts      var_ty       = idType var     (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes@@ -356,7 +354,7 @@     mk_case :: CoreExpr -> DsM CoreExpr     mk_case fail = do         alts <- mapM (mk_alt fail) sorted_alts-        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ NEL.toList alts)      mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt     mk_alt fail MkCaseAlt{ alt_pat = con,@@ -376,11 +374,11 @@      fail_flag :: CanItFail     fail_flag | exhaustive_case-              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- NEL.toList match_results]               | otherwise               = CanFail -    mentioned_constructors = mkUniqSet $ map alt_pat alts+    mentioned_constructors = mkUniqSet $ map alt_pat $ NEL.toList alts     un_mentioned_constructors         = mkUniqSet data_cons `minusUniqSet` mentioned_constructors     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
compiler/deSugar/ExtractDocs.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module ExtractDocs (extractDocs) where  import GhcPrelude
compiler/deSugar/Match.hs view
@@ -7,9 +7,14 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module Match ( match, matchEquations, matchWrapper, matchSimply              , matchSinglePat, matchSinglePatVar ) where @@ -55,7 +60,8 @@ import UniqDFM  import Control.Monad( when, unless )-import Data.List ( groupBy )+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map  {-@@ -161,11 +167,10 @@  type MatchId = Id   -- See Note [Match Ids] -match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with-                          -- ^ See Note [Match Ids]-      -> Type             -- ^ Type of the case expression-      -> [EquationInfo]   -- ^ Info about patterns, etc. (type synonym below)-      -> DsM MatchResult  -- ^ Desugared result!+match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with. See Note [Match Ids]+      -> Type -- ^ Type of the case expression+      -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below)+      -> DsM MatchResult -- ^ Desugared result!  match [] ty eqns   = ASSERT2( not (null eqns), ppr ty )@@ -175,13 +180,12 @@                       eqn_rhs eqn                     | eqn <- eqns ] -match vars@(v:_) ty eqns    -- Eqns *can* be empty+match (v:vs) ty eqns    -- Eqns *can* be empty   = ASSERT2( all (isInternalName . idName) vars, ppr vars )     do  { dflags <- getDynFlags                 -- Tidy the first pattern, generating                 -- auxiliary bindings if necessary         ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns-                 -- Group the equations and match each group in turn         ; let grouped = groupEquations dflags tidy_eqns @@ -192,21 +196,22 @@         ; return (adjustMatchResult (foldr (.) id aux_binds) $                   foldr1 combineMatchResults match_results) }   where-    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]-    dropGroup = map snd+    vars = v :| vs -    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]+    dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo+    dropGroup = fmap snd++    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty MatchResult)     -- Result list of [MatchResult] is always non-empty     match_groups [] = matchEmpty v ty-    match_groups gs = mapM match_group gs+    match_groups (g:gs) = mapM match_group $ g :| gs -    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult-    match_group [] = panic "match_group"-    match_group eqns@((group,_) : _)+    match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM MatchResult+    match_group eqns@((group,_) :| _)         = case group of-            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])+            PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])             PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)-            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])+            PgLit {}  -> matchLiterals   vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])             PgAny     -> matchVariables  vars ty (dropGroup eqns)             PgN {}    -> matchNPats      vars ty (dropGroup eqns)             PgOverS {}-> matchNPats      vars ty (dropGroup eqns)@@ -215,6 +220,10 @@             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)             PgView {} -> matchView       vars ty (dropGroup eqns)             PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)+      where eqns' = NEL.toList eqns+            ne l = case NEL.nonEmpty l of+              Just nel -> nel+              Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"      -- FIXME: we should also warn about view patterns that should be     -- commoned up but are not@@ -231,7 +240,7 @@           maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))                        (filter (not . null) gs)) -matchEmpty :: MatchId -> Type -> DsM [MatchResult]+matchEmpty :: MatchId -> Type -> DsM (NonEmpty MatchResult) -- See Note [Empty case expressions] matchEmpty var res_ty   = return [MatchResult CanFail mk_seq]@@ -239,35 +248,32 @@     mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty                                       [(DEFAULT, [], fail)] -matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult -- Real true variables, just like in matchVar, SLPJ p 94 -- No binding to do: they'll all be wildcards by now (done in tidy)-matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)-matchVariables [] _ _ = panic "matchVariables"+matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns -matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult-matchBangs (var:vars) ty eqns-  = do  { match_result <- match (var:vars) ty $-                          map (decomposeFirstPat getBangPat) eqns+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult+matchBangs (var :| vars) ty eqns+  = do  { match_result <- match (var:vars) ty $ NEL.toList $+            decomposeFirstPat getBangPat <$> eqns         ; return (mkEvalMatchResult var ty match_result) }-matchBangs [] _ _ = panic "matchBangs" -matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult -- Apply the coercion to the match variable and then match that-matchCoercion (var:vars) ty (eqns@(eqn1:_))+matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))   = do  { let CoPat _ co pat _ = firstPat eqn1         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var pat_ty'-        ; match_result <- match (var':vars) ty $-                          map (decomposeFirstPat getCoPat) eqns+        ; match_result <- match (var':vars) ty $ NEL.toList $+            decomposeFirstPat getCoPat <$> eqns         ; core_wrap <- dsHsWrapper co         ; let bind = NonRec var' (core_wrap (Var var))         ; return (mkCoLetMatchResult bind match_result) }-matchCoercion _ _ _ = panic "matchCoercion" -matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult -- Apply the view function to the match variable and then match that-matchView (var:vars) ty (eqns@(eqn1:_))+matchView (var :| vars) ty (eqns@(eqn1 :| _))   = do  { -- we could pass in the expr from the PgView,          -- but this needs to extract the pat anyway          -- to figure out the type of the fresh variable@@ -275,26 +281,25 @@          -- do the rest of the compilation         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var pat_ty'-        ; match_result <- match (var':vars) ty $-                          map (decomposeFirstPat getViewPat) eqns+        ; match_result <- match (var':vars) ty $ NEL.toList $+            decomposeFirstPat getViewPat <$> eqns          -- compile the view expressions         ; viewExpr' <- dsLExpr viewExpr         ; return (mkViewMatchResult var'                     (mkCoreAppDs (text "matchView") viewExpr' (Var var))                     match_result) }-matchView _ _ _ = panic "matchView" -matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult-matchOverloadedList (var:vars) ty (eqns@(eqn1:_))+matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM MatchResult+matchOverloadedList (var :| vars) ty (eqns@(eqn1 :| _)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView   = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1        ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand-       ; match_result <- match (var':vars) ty $-                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern+       ; match_result <- match (var':vars) ty $ NEL.toList $+           decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern        ; e' <- dsSyntaxExpr e [Var var]-       ; return (mkViewMatchResult var' e' match_result) }-matchOverloadedList _ _ _ = panic "matchOverloadedList"+       ; return (mkViewMatchResult var' e' match_result)+       }  -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo@@ -754,7 +759,7 @@             ; match_result <-               -- Extend the environment with knowledge about-              -- the matches before desguaring the RHS+              -- the matches before desugaring the RHS               -- See Note [Type and Term Equality Propagation]               applyWhen (needToRunPmCheck dflags origin)                         (addTyCsDs dicts . addScrutTmCs mb_scr vars . addPatTmCs upats vars)@@ -889,22 +894,24 @@ for overloaded strings. -} -groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]+groupEquations :: DynFlags -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty -- The ordering of equations is unchanged groupEquations dflags eqns-  = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]+  = NEL.groupBy same_gp $ [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]+  -- comprehension on NonEmpty   where     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 -subGroup :: (m -> [[EquationInfo]]) -- Map.elems+-- TODO Make subGroup1 using a NonEmptyMap+subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems          -> m -- Map.empty-         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup-         -> (a -> [EquationInfo] -> m -> m) -- Map.insert-         -> [(a, EquationInfo)] -> [[EquationInfo]]+         -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup+         -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert+         -> [(a, EquationInfo)] -> [NonEmpty EquationInfo] -- Input is a particular group.  The result sub-groups the -- equations by with particular constructor, literal etc they match. -- Each sub-list in the result has the same PatGroup@@ -912,19 +919,19 @@ -- Parameterized by map operations to allow different implementations -- and constraints, eg. types without Ord instance. subGroup elems empty lookup insert group-    = map reverse $ elems $ foldl' accumulate empty group+    = fmap NEL.reverse $ elems $ foldl' accumulate empty group   where     accumulate pg_map (pg, eqn)       = case lookup pg pg_map of-          Just eqns -> insert pg (eqn:eqns) pg_map-          Nothing   -> insert pg [eqn]      pg_map+          Just eqns -> insert pg (NEL.cons eqn eqns) pg_map+          Nothing   -> insert pg [eqn] pg_map     -- pg_map :: Map a [EquationInfo]     -- Equations seen so far in reverse order of appearance -subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert -subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo] subGroupUniq =   subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v) @@ -948,7 +955,7 @@ match.  Conclusion: we can combine when we invoke PRead /at the same type/.  Hence-in PgSyn we record the instantiaing types, and use them in sameGroup.+in PgSyn we record the instantiating types, and use them in sameGroup.  Note [Take care with pattern order] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/deSugar/MatchCon.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module MatchCon ( matchConFamily, matchPatSyn ) where  #include "HsVersions.h"@@ -34,6 +36,7 @@ import Outputable import Control.Monad(liftM) import Data.List (groupBy)+import Data.List.NonEmpty (NonEmpty(..))  {- We are confronted with the first column of patterns in a set of@@ -88,40 +91,38 @@ @match_cons_used@ does all the real work. -} -matchConFamily :: [Id]+matchConFamily :: NonEmpty Id                -> Type-               -> [[EquationInfo]]+               -> NonEmpty (NonEmpty EquationInfo)                -> DsM MatchResult -- Each group of eqns is for a single constructor-matchConFamily (var:vars) ty groups+matchConFamily (var :| vars) ty groups   = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups        return (mkCoAlgCaseMatchResult var ty alts)   where     toRealAlt alt = case alt_pat alt of         RealDataCon dcon -> alt{ alt_pat = dcon }         _ -> panic "matchConFamily: not RealDataCon"-matchConFamily [] _ _ = panic "matchConFamily []" -matchPatSyn :: [Id]+matchPatSyn :: NonEmpty Id             -> Type-            -> [EquationInfo]+            -> NonEmpty EquationInfo             -> DsM MatchResult-matchPatSyn (var:vars) ty eqns+matchPatSyn (var :| vars) ty eqns   = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns        return (mkCoSynCaseMatchResult var ty alt)   where     toSynAlt alt = case alt_pat alt of         PatSynCon psyn -> alt{ alt_pat = psyn }         _ -> panic "matchPatSyn: not PatSynCon"-matchPatSyn _ _ _ = panic "matchPatSyn []"  type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))  matchOneConLike :: [Id]                 -> Type-                -> [EquationInfo]+                -> NonEmpty EquationInfo                 -> DsM (CaseAlt ConLike)-matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor+matchOneConLike vars ty (eqn1 :| eqns)   -- All eqns for a single constructor   = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )                            -- ex_tvs can only be tyvars as data types in source                            -- Haskell cannot mention covar yet (Aug 2018).@@ -195,7 +196,6 @@         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env                                             (idName (unLoc (hsRecFieldId rpat)))     select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"-matchOneConLike _ _ [] = panic "matchOneCon []"  ----------------- compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool@@ -253,7 +253,7 @@  In the first we must test y first; in the second we must test x first.  So we must divide even the equations for a single constructor-T into sub-goups, based on whether they match the same field in the+T into sub-groups, based on whether they match the same field in the same order.  That's what the (groupBy compatible_pats) grouping.  All non-record patterns are "compatible" in this sense, because the
compiler/deSugar/MatchLit.hs view
@@ -9,6 +9,8 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module MatchLit ( dsLit, dsOverLit, hsLitKey                 , tidyLitPat, tidyNPat                 , matchLiterals, matchNPlusKPats, matchNPats@@ -53,6 +55,8 @@  import Control.Monad import Data.Int+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL import Data.Word import Data.Proxy @@ -164,7 +168,7 @@   dflags <- getDynFlags   warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit) --- | Emit warnings on integral literals which overflow the boudns implied by+-- | Emit warnings on integral literals which overflow the bounds implied by -- their type. warnAboutOverflowedLit :: HsLit GhcTc -> DsM () warnAboutOverflowedLit hsLit = do@@ -397,14 +401,13 @@ ************************************************************************ -} -matchLiterals :: [Id]-              -> Type                   -- Type of the whole case expression-              -> [[EquationInfo]]       -- All PgLits+matchLiterals :: NonEmpty Id+              -> Type -- ^ Type of the whole case expression+              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits               -> DsM MatchResult -matchLiterals (var:vars) ty sub_groups-  = ASSERT( notNull sub_groups && all notNull sub_groups )-    do  {       -- Deal with each group+matchLiterals (var :| vars) ty sub_groups+  = do  {       -- Deal with each group         ; alts <- mapM match_group sub_groups                  -- Combine results.  For everything except String@@ -415,14 +418,14 @@                 ; mrs <- mapM (wrap_str_guard eq_str) alts                 ; return (foldr1 combineMatchResults mrs) }           else-            return (mkCoPrimCaseMatchResult var ty alts)+            return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)         }   where-    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)-    match_group eqns+    match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult)+    match_group eqns@(firstEqn :| _)         = do { dflags <- getDynFlags-             ; let LitPat _ hs_lit = firstPat (head eqns)-             ; match_result <- match vars ty (shiftEqns eqns)+             ; let LitPat _ hs_lit = firstPat firstEqn+             ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)              ; return (hsLitKey dflags hs_lit, match_result) }      wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult@@ -436,7 +439,6 @@              ; return (mkGuardedMatchResult pred mr) }     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) -matchLiterals [] _ _ = panic "matchLiterals []"  --------------------------- hsLitKey :: DynFlags -> HsLit GhcTc -> Literal@@ -467,8 +469,8 @@ ************************************************************************ -} -matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult-matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal+matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult+matchNPats (var :| vars) ty (eqn1 :| eqns)    -- All for the same literal   = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1         ; lit_expr <- dsOverLit lit         ; neg_lit <- case mb_neg of@@ -477,7 +479,6 @@         ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))         ; return (mkGuardedMatchResult pred_expr match_result) }-matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))  {- ************************************************************************@@ -497,9 +498,9 @@ \end{verbatim} -} -matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM MatchResult -- All NPlusKPats, for the *same* literal k-matchNPlusKPats (var:vars) ty (eqn1:eqns)+matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)   = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus                 = firstPat eqn1         ; lit1_expr   <- dsOverLit lit1@@ -517,5 +518,3 @@         = (wrapBind n n1, eqn { eqn_pats = pats })         -- The wrapBind is a no-op for the first equation     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)--matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
compiler/ghci/ByteCodeAsm.hs view
@@ -30,7 +30,7 @@ import TyCon import FastString import GHC.StgToCmm.Layout     ( ArgRep(..) )-import SMRep+import GHC.Runtime.Layout import DynFlags import Outputable import GHC.Platform
compiler/ghci/ByteCodeGen.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fprof-auto-top #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- --  (c) The University of Glasgow 2002-2006 --@@ -50,8 +51,8 @@ import Panic import GHC.StgToCmm.Closure    ( NonVoid(..), fromNonVoid, nonVoidIds ) import GHC.StgToCmm.Layout-import SMRep hiding (WordOff, ByteOff, wordsToBytes)-import Bitmap+import GHC.Runtime.Layout hiding (WordOff, ByteOff, wordsToBytes)+import GHC.Data.Bitmap import OrdList import Maybes import VarEnv@@ -997,7 +998,7 @@         ret_frame_size_b :: StackDepth         ret_frame_size_b = 2 * wordSize dflags -        -- The extra frame we push to save/restor the CCCS when profiling+        -- The extra frame we push to save/restore the CCCS when profiling         save_ccs_size_b | profiling = 2 * wordSize dflags                         | otherwise = 0 @@ -1473,7 +1474,7 @@ The 'bogus-word' push is because TESTEQ_I expects the top of the stack to have an info-table, and the next word to have the value to be tested.  This is very weird, but it's the way it is right now.  See-Interpreter.c.  We don't acutally need an info-table here; we just+Interpreter.c.  We don't actually need an info-table here; we just need to have the argument to be one-from-top on the stack, hence pushing a 1-word null. See #8383. -}
compiler/ghci/ByteCodeInstr.hs view
@@ -28,7 +28,7 @@ import DataCon import VarSet import PrimOp-import SMRep+import GHC.Runtime.Layout  import Data.Word import GHC.Stack.CCS (CostCentre)@@ -68,7 +68,7 @@    | PUSH32 !Word16     -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the-   -- value will take the whole word on the stack (i.e., the stack will gorw by+   -- value will take the whole word on the stack (i.e., the stack will grow by    -- a word)    -- This is useful when extracting a packed constructor field for further use.    -- Currently we expect all values on the stack to take full words, except for
compiler/ghci/Debugger.hs view
@@ -24,8 +24,8 @@ import GhcMonad import HscTypes import Id-import IfaceSyn ( showToHeader )-import IfaceEnv( newInteractiveBinder )+import GHC.Iface.Syntax ( showToHeader )+import GHC.Iface.Env    ( newInteractiveBinder ) import Name import Var hiding ( varName ) import VarSet
compiler/ghci/Linker.hs view
@@ -24,7 +24,7 @@  import GHCi import GHCi.RemoteTypes-import LoadIface+import GHC.Iface.Load import ByteCodeLink import ByteCodeAsm import ByteCodeTypes@@ -1139,7 +1139,8 @@        -- Code unloading currently disabled due to instability.       -- See #16841.-      | False -- otherwise+      -- id False, so that the pattern-match checker doesn't complain+      | id False -- otherwise       = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]                 -- The components of a BCO linkable may contain                 -- dot-o files.  Which is very confusing.@@ -1254,7 +1255,7 @@         = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))  -linkPackage :: HscEnv -> PackageConfig -> IO ()+linkPackage :: HscEnv -> UnitInfo -> IO () linkPackage hsc_env pkg    = do         let dflags    = hsc_dflags hsc_env@@ -1407,7 +1408,7 @@       , "(the package DLL is loaded by the system linker"       , " which manages dependencies by itself)." ] -loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()+loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO () loadFrameworks hsc_env platform pkg     = when (platformUsesFrameworks platform) $ mapM_ load frameworks   where
compiler/ghci/RtClosureInspect.hs view
@@ -47,7 +47,7 @@ import Name import OccName import Module-import IfaceEnv+import GHC.Iface.Env import Util import VarSet import BasicTypes       ( Boxity(..) )@@ -58,7 +58,7 @@ import Outputable as Ppr import GHC.Char import GHC.Exts.Heap-import SMRep ( roundUpTo )+import GHC.Runtime.Layout ( roundUpTo )  import Control.Monad import Data.Maybe
− compiler/hieFile/HieAst.hs 
@@ -1,1917 +0,0 @@-{--Main functions for .hie file generation--}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-module HieAst ( mkHieFile ) where--import GhcPrelude--import Avail                      ( Avails )-import Bag                        ( Bag, bagToList )-import BasicTypes-import BooleanFormula-import Class                      ( FunDep )-import CoreUtils                  ( exprType )-import ConLike                    ( conLikeName )-import Desugar                    ( deSugarExpr )-import FieldLabel-import GHC.Hs-import HscTypes-import Module                     ( ModuleName, ml_hs_file )-import MonadUtils                 ( concatMapM, liftIO )-import Name                       ( Name, nameSrcSpan, setNameLoc )-import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )-import SrcLoc-import TcHsSyn                    ( hsLitType, hsPatType )-import Type                       ( mkVisFunTys, Type )-import TysWiredIn                 ( mkListTy, mkSumTy )-import Var                        ( Id, Var, setVarName, varName, varType )-import TcRnTypes-import MkIface                    ( mkIfaceExports )-import Panic--import HieTypes-import HieUtils--import qualified Data.Array as A-import qualified Data.ByteString as BS-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Data                  ( Data, Typeable )-import Data.List                  ( foldl1' )-import Data.Maybe                 ( listToMaybe )-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class  ( lift )--{- Note [Updating HieAst for changes in the GHC AST]--When updating the code in this file for changes in the GHC AST, you-need to pay attention to the following things:--1) Symbols (Names/Vars/Modules) in the following categories:--   a) Symbols that appear in the source file that directly correspond to-   something the user typed-   b) Symbols that don't appear in the source, but should be in some sense-   "visible" to a user, particularly via IDE tooling or the like. This-   includes things like the names introduced by RecordWildcards (We record-   all the names introduced by a (..) in HIE files), and will include implicit-   parameters and evidence variables after one of my pending MRs lands.--2) Subtrees that may contain such symbols, or correspond to a SrcSpan in-   the file. This includes all `Located` things--For 1), you need to call `toHie` for one of the following instances--instance ToHie (Context (Located Name)) where ...-instance ToHie (Context (Located Var)) where ...-instance ToHie (IEContext (Located ModuleName)) where ...--`Context` is a data type that looks like:--data Context a = C ContextInfo a -- Used for names and bindings--`ContextInfo` is defined in `HieTypes`, and looks like--data ContextInfo-  = Use                -- ^ regular variable-  | MatchBind-  | IEThing IEType     -- ^ import/export-  | TyDecl-  -- | Value binding-  | ValBind-      BindType     -- ^ whether or not the binding is in an instance-      Scope        -- ^ scope over which the value is bound-      (Maybe Span) -- ^ span of entire binding-  ...--It is used to annotate symbols in the .hie files with some extra information on-the context in which they occur and should be fairly self explanatory. You need-to select one that looks appropriate for the symbol usage. In very rare cases,-you might need to extend this sum type if none of the cases seem appropriate.--So, given a `Located Name` that is just being "used", and not defined at a-particular location, you would do the following:--   toHie $ C Use located_name--If you select one that corresponds to a binding site, you will need to-provide a `Scope` and a `Span` for your binding. Both of these are basically-`SrcSpans`.--The `SrcSpan` in the `Scope` is supposed to span over the part of the source-where the symbol can be legally allowed to occur. For more details on how to-calculate this, see Note [Capturing Scopes and other non local information]-in HieAst.--The binding `Span` is supposed to be the span of the entire binding for-the name.--For a function definition `foo`:--foo x = x + y-  where y = x^2--The binding `Span` is the span of the entire function definition from `foo x`-to `x^2`.  For a class definition, this is the span of the entire class, and-so on.  If this isn't well defined for your bit of syntax (like a variable-bound by a lambda), then you can just supply a `Nothing`--There is a test that checks that all symbols in the resulting HIE file-occur inside their stated `Scope`. This can be turned on by passing the--fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the-.hie file.--You may also want to provide a test in testsuite/test/hiefile that includes-a file containing your new construction, and tests that the calculated scope-is valid (by using -fvalidate-ide-info)--For subtrees in the AST that may contain symbols, the procedure is fairly-straightforward.  If you are extending the GHC AST, you will need to provide a-`ToHie` instance for any new types you may have introduced in the AST.--Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):--  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of-      HsVar _ (L _ var) ->-        [ toHie $ C Use (L mspan var)-             -- Patch up var location since typechecker removes it-        ]-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]-      ...-      HsApp _ a b ->-        [ toHie a-        , toHie b-        ]--If your subtree is `Located` or has a `SrcSpan` available, the output list-should contain a HieAst `Node` corresponding to the subtree. You can use-either `makeNode` or `getTypeNode` for this purpose, depending on whether it-makes sense to assign a `Type` to the subtree. After this, you just need-to concatenate the result of calling `toHie` on all subexpressions and-appropriately annotated symbols contained in the subtree.--The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed-to work for both the renamed and typechecked source. `getTypeNode` is from-the `HasType` class defined in this file, and it has different instances-for `GhcTc` and `GhcRn` that allow it to access the type of the expression-when given a typechecked AST:--class Data a => HasType a where-  getTypeNode :: a -> HieM [HieAST Type]-instance HasType (LHsExpr GhcTc) where-  getTypeNode e@(L spn e') = ... -- Actually get the type for this expression-instance HasType (LHsExpr GhcRn) where-  getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type--If your subtree doesn't have a span available, you can omit the `makeNode`-call and just recurse directly in to the subexpressions.---}---- These synonyms match those defined in main/GHC.hs-type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]-                         , Maybe [(LIE GhcRn, Avails)]-                         , Maybe LHsDocString )-type TypecheckedSource = LHsBinds GhcTc---{- Note [Name Remapping]-The Typechecker introduces new names for mono names in AbsBinds.-We don't care about the distinction between mono and poly bindings,-so we replace all occurrences of the mono name with the poly name.--}-newtype HieState = HieState-  { name_remapping :: NameEnv Id-  }--initState :: HieState-initState = HieState emptyNameEnv--class ModifyState a where -- See Note [Name Remapping]-  addSubstitution :: a -> a -> HieState -> HieState--instance ModifyState Name where-  addSubstitution _ _ hs = hs--instance ModifyState Id where-  addSubstitution mono poly hs =-    hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}--modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState-modifyState = foldr go id-  where-    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f-    go _ f = f--type HieM = ReaderT HieState Hsc---- | Construct an 'HieFile' from the outputs of the typechecker.-mkHieFile :: ModSummary-          -> TcGblEnv-          -> RenamedSource -> Hsc HieFile-mkHieFile ms ts rs = do-  let tc_binds = tcg_binds ts-  (asts', arr) <- getCompressedAsts tc_binds rs-  let Just src_file = ml_hs_file $ ms_location ms-  src <- liftIO $ BS.readFile src_file-  return $ HieFile-      { hie_hs_file = src_file-      , hie_module = ms_mod ms-      , hie_types = arr-      , hie_asts = asts'-      -- mkIfaceExports sorts the AvailInfos for stability-      , hie_exports = mkIfaceExports (tcg_exports ts)-      , hie_hs_src = src-      }--getCompressedAsts :: TypecheckedSource -> RenamedSource-  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)-getCompressedAsts ts rs = do-  asts <- enrichHie ts rs-  return $ compressTypes asts--enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)-enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do-    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts-    rasts <- processGrp hsGrp-    imps <- toHie $ filter (not . ideclImplicit . unLoc) imports-    exps <- toHie $ fmap (map $ IEC Export . fst) exports-    let spanFile children = case children of-          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)-          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)-                             (realSrcSpanEnd   $ nodeSpan $ last children)--        modulify xs =-          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs--        asts = HieASTs-          $ resolveTyVarScopes-          $ M.map (modulify . mergeSortAsts)-          $ M.fromListWith (++)-          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts--        flat_asts = concat-          [ tasts-          , rasts-          , imps-          , exps-          ]-    return asts-  where-    processGrp grp = concatM-      [ toHie $ fmap (RS ModuleScope ) hs_valds grp-      , toHie $ hs_splcds grp-      , toHie $ hs_tyclds grp-      , toHie $ hs_derivds grp-      , toHie $ hs_fixds grp-      , toHie $ hs_defds grp-      , toHie $ hs_fords grp-      , toHie $ hs_warnds grp-      , toHie $ hs_annds grp-      , toHie $ hs_ruleds grp-      ]--getRealSpan :: SrcSpan -> Maybe Span-getRealSpan (RealSrcSpan sp) = Just sp-getRealSpan _ = Nothing--grhss_span :: GRHSs p body -> SrcSpan-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)-grhss_span (XGRHSs _) = panic "XGRHS has no span"--bindingsOnly :: [Context Name] -> [HieAST a]-bindingsOnly [] = []-bindingsOnly (C c n : xs) = case nameSrcSpan n of-  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs-    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)-          info = mempty{identInfo = S.singleton c}-  _ -> bindingsOnly xs--concatM :: Monad m => [m [a]] -> m [a]-concatM xs = concat <$> sequence xs--{- Note [Capturing Scopes and other non local information]-toHie is a local tranformation, but scopes of bindings cannot be known locally,-hence we have to push the relevant info down into the binding nodes.-We use the following types (*Context and *Scoped) to wrap things and-carry the required info-(Maybe Span) always carries the span of the entire binding, including rhs--}-data Context a = C ContextInfo a -- Used for names and bindings--data RContext a = RC RecFieldContext a-data RFContext a = RFC RecFieldContext (Maybe Span) a--- ^ context for record fields--data IEContext a = IEC IEType a--- ^ context for imports/exports--data BindContext a = BC BindType Scope a--- ^ context for imports/exports--data PatSynFieldContext a = PSC (Maybe Span) a--- ^ context for pattern synonym fields.--data SigContext a = SC SigInfo a--- ^ context for type signatures--data SigInfo = SI SigType (Maybe Span)--data SigType = BindSig | ClassSig | InstSig--data RScoped a = RS Scope a--- ^ Scope spans over everything to the right of a, (mostly) not--- including a itself--- (Includes a in a few special cases like recursive do bindings) or--- let/where bindings---- | Pattern scope-data PScoped a = PS (Maybe Span)-                    Scope       -- ^ use site of the pattern-                    Scope       -- ^ pattern to the right of a, not including a-                    a-  deriving (Typeable, Data) -- Pattern Scope--{- Note [TyVar Scopes]-Due to -XScopedTypeVariables, type variables can be in scope quite far from-their original binding. We resolve the scope of these type variables-in a separate pass--}-data TScoped a = TS TyVarScope a -- TyVarScope--data TVScoped a = TVS TyVarScope Scope a -- TyVarScope--- ^ First scope remains constant--- Second scope is used to build up the scope of a tyvar over--- things to its right, ala RScoped---- | Each element scopes over the elements to the right-listScopes :: Scope -> [Located a] -> [RScoped (Located a)]-listScopes _ [] = []-listScopes rhsScope [pat] = [RS rhsScope pat]-listScopes rhsScope (pat : pats) = RS sc pat : pats'-  where-    pats'@((RS scope p):_) = listScopes rhsScope pats-    sc = combineScopes scope $ mkScope $ getLoc p---- | 'listScopes' specialised to 'PScoped' things-patScopes-  :: Maybe Span-  -> Scope-  -> Scope-  -> [LPat (GhcPass p)]-  -> [PScoped (LPat (GhcPass p))]-patScopes rsp useScope patScope xs =-  map (\(RS sc a) -> PS rsp useScope sc a) $-    listScopes patScope xs---- | 'listScopes' specialised to 'TVScoped' things-tvScopes-  :: TyVarScope-  -> Scope-  -> [LHsTyVarBndr a]-  -> [TVScoped (LHsTyVarBndr a)]-tvScopes tvScope rhsScope xs =-  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs--{- Note [Scoping Rules for SigPat]-Explicitly quantified variables in pattern type signatures are not-brought into scope in the rhs, but implicitly quantified variables-are (HsWC and HsIB).-This is unlike other signatures, where explicitly quantified variables-are brought into the RHS Scope-For example-foo :: forall a. ...;-foo = ... -- a is in scope here--bar (x :: forall a. a -> a) = ... -- a is not in scope here---   ^ a is in scope here (pattern body)--bax (x :: a) = ... -- a is in scope here-Because of HsWC and HsIB pass on their scope to their children-we must wrap the LHsType in pattern signatures in a-Shielded explicitly, so that the HsWC/HsIB scope is not passed-on the the LHsType--}--data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead--type family ProtectedSig a where-  ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs-                                                GhcRn-                                                (Shielded (LHsType GhcRn)))-  ProtectedSig GhcTc = NoExtField--class ProtectSig a where-  protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a--instance (HasLoc a) => HasLoc (Shielded a) where-  loc (SH _ a) = loc a--instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where-  toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)--instance ProtectSig GhcTc where-  protectSig _ _ = noExtField--instance ProtectSig GhcRn where-  protectSig sc (HsWC a (HsIB b sig)) =-    HsWC a (HsIB b (SH sc sig))-  protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec-  protectSig _ (XHsWildCardBndrs nec) = noExtCon nec--class HasLoc a where-  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can-  -- know what their implicit bindings are scoping over-  loc :: a -> SrcSpan--instance HasLoc thing => HasLoc (TScoped thing) where-  loc (TS _ a) = loc a--instance HasLoc thing => HasLoc (PScoped thing) where-  loc (PS _ _ _ a) = loc a--instance HasLoc (LHsQTyVars GhcRn) where-  loc (HsQTvs _ vs) = loc vs-  loc _ = noSrcSpan--instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where-  loc (HsIB _ a) = loc a-  loc _ = noSrcSpan--instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where-  loc (HsWC _ a) = loc a-  loc _ = noSrcSpan--instance HasLoc (Located a) where-  loc (L l _) = l--instance HasLoc a => HasLoc [a] where-  loc [] = noSrcSpan-  loc xs = foldl1' combineSrcSpans $ map loc xs--instance HasLoc a => HasLoc (FamEqn s a) where-  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]-  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans-                                              [loc a, loc tvs, loc b, loc c]-  loc _ = noSrcSpan-instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where-  loc (HsValArg tm) = loc tm-  loc (HsTypeArg _ ty) = loc ty-  loc (HsArgPar sp)  = sp--instance HasLoc (HsDataDefn GhcRn) where-  loc def@(HsDataDefn{}) = loc $ dd_cons def-    -- Only used for data family instances, so we only need rhs-    -- Most probably the rest will be unhelpful anyway-  loc _ = noSrcSpan--{- Note [Real DataCon Name]-The typechecker subtitutes the conLikeWrapId for the name, but we don't want-this showing up in the hieFile, so we replace the name in the Id with the-original datacon name-See also Note [Data Constructor Naming]--}-class HasRealDataConName p where-  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)--instance HasRealDataConName GhcRn where-  getRealDataCon _ n = n-instance HasRealDataConName GhcTc where-  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =-    L sp (setVarName var (conLikeName con))---- | The main worker class--- See Note [Updating HieAst for changes in the GHC AST] for more information--- on how to add/modify instances for this.-class ToHie a where-  toHie :: a -> HieM [HieAST Type]---- | Used to collect type info-class Data a => HasType a where-  getTypeNode :: a -> HieM [HieAST Type]--instance (ToHie a) => ToHie [a] where-  toHie = concatMapM toHie--instance (ToHie a) => ToHie (Bag a) where-  toHie = toHie . bagToList--instance (ToHie a) => ToHie (Maybe a) where-  toHie = maybe (pure []) toHie--instance ToHie (Context (Located NoExtField)) where-  toHie _ = pure []--instance ToHie (TScoped NoExtField) where-  toHie _ = pure []--instance ToHie (IEContext (Located ModuleName)) where-  toHie (IEC c (L (RealSrcSpan span) mname)) =-      pure $ [Node (NodeInfo S.empty [] idents) span []]-    where details = mempty{identInfo = S.singleton (IEThing c)}-          idents = M.singleton (Left mname) details-  toHie _ = pure []--instance ToHie (Context (Located Var)) where-  toHie c = case c of-      C context (L (RealSrcSpan span) name')-        -> do-        m <- asks name_remapping-        let name = case lookupNameEnv m (varName name') of-              Just var -> var-              Nothing-> name'-        pure-          [Node-            (NodeInfo S.empty [] $-              M.singleton (Right $ varName name)-                          (IdentifierDetails (Just $ varType name')-                                             (S.singleton context)))-            span-            []]-      _ -> pure []--instance ToHie (Context (Located Name)) where-  toHie c = case c of-      C context (L (RealSrcSpan span) name') -> do-        m <- asks name_remapping-        let name = case lookupNameEnv m name' of-              Just var -> varName var-              Nothing -> name'-        pure-          [Node-            (NodeInfo S.empty [] $-              M.singleton (Right name)-                          (IdentifierDetails Nothing-                                             (S.singleton context)))-            span-            []]-      _ -> pure []---- | Dummy instances - never called-instance ToHie (TScoped (LHsSigWcType GhcTc)) where-  toHie _ = pure []-instance ToHie (TScoped (LHsWcType GhcTc)) where-  toHie _ = pure []-instance ToHie (SigContext (LSig GhcTc)) where-  toHie _ = pure []-instance ToHie (TScoped Type) where-  toHie _ = pure []--instance HasType (LHsBind GhcRn) where-  getTypeNode (L spn bind) = makeNode bind spn--instance HasType (LHsBind GhcTc) where-  getTypeNode (L spn bind) = case bind of-      FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)-      _ -> makeNode bind spn--instance HasType (Located (Pat GhcRn)) where-  getTypeNode (L spn pat) = makeNode pat spn--instance HasType (Located (Pat GhcTc)) where-  getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat)--instance HasType (LHsExpr GhcRn) where-  getTypeNode (L spn e) = makeNode e spn---- | This instance tries to construct 'HieAST' nodes which include the type of--- the expression. It is not yet possible to do this efficiently for all--- expression forms, so we skip filling in the type for those inputs.------ 'HsApp', for example, doesn't have any type information available directly on--- the node. Our next recourse would be to desugar it into a 'CoreExpr' then--- query the type of that. Yet both the desugaring call and the type query both--- involve recursive calls to the function and argument! This is particularly--- problematic when you realize that the HIE traversal will eventually visit--- those nodes too and ask for their types again.------ Since the above is quite costly, we just skip cases where computing the--- expression's type is going to be expensive.------ See #16233-instance HasType (LHsExpr GhcTc) where-  getTypeNode e@(L spn e') = lift $-    -- Some expression forms have their type immediately available-    let tyOpt = case e' of-          HsLit _ l -> Just (hsLitType l)-          HsOverLit _ o -> Just (overLitType o)--          HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)-          HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)-          HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)--          ExplicitList  ty _ _   -> Just (mkListTy ty)-          ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)-          HsDo          ty _ _   -> Just ty-          HsMultiIf     ty _     -> Just ty--          _ -> Nothing--    in-    case tyOpt of-      Just t -> makeTypeNode e' spn t-      Nothing-        | skipDesugaring e' -> fallback-        | otherwise -> do-            hs_env <- Hsc $ \e w -> return (e,w)-            (_,mbe) <- liftIO $ deSugarExpr hs_env e-            maybe fallback (makeTypeNode e' spn . exprType) mbe-    where-      fallback = makeNode e' spn--      matchGroupType :: MatchGroupTc -> Type-      matchGroupType (MatchGroupTc args res) = mkVisFunTys args res--      -- | Skip desugaring of these expressions for performance reasons.-      ---      -- See impact on Haddock output (esp. missing type annotations or links)-      -- before marking more things here as 'False'. See impact on Haddock-      -- performance before marking more things as 'True'.-      skipDesugaring :: HsExpr a -> Bool-      skipDesugaring e = case e of-        HsVar{}        -> False-        HsUnboundVar{} -> False-        HsConLikeOut{} -> False-        HsRecFld{}     -> False-        HsOverLabel{}  -> False-        HsIPVar{}      -> False-        HsWrap{}       -> False-        _              -> True--instance ( ToHie (Context (Located (IdP a)))-         , ToHie (MatchGroup a (LHsExpr a))-         , ToHie (PScoped (LPat a))-         , ToHie (GRHSs a (LHsExpr a))-         , ToHie (LHsExpr a)-         , ToHie (Located (PatSynBind a a))-         , HasType (LHsBind a)-         , ModifyState (IdP a)-         , Data (HsBind a)-         ) => ToHie (BindContext (LHsBind a)) where-  toHie (BC context scope b@(L span bind)) =-    concatM $ getTypeNode b : case bind of-      FunBind{fun_id = name, fun_matches = matches} ->-        [ toHie $ C (ValBind context scope $ getRealSpan span) name-        , toHie matches-        ]-      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->-        [ toHie $ PS (getRealSpan span) scope NoScope lhs-        , toHie rhs-        ]-      VarBind{var_rhs = expr} ->-        [ toHie expr-        ]-      AbsBinds{abs_exports = xs, abs_binds = binds} ->-        [ local (modifyState xs) $ -- Note [Name Remapping]-            toHie $ fmap (BC context scope) binds-        ]-      PatSynBind _ psb ->-        [ toHie $ L span psb -- PatSynBinds only occur at the top level-        ]-      XHsBindsLR _ -> []--instance ( ToHie (LMatch a body)-         ) => ToHie (MatchGroup a body) where-  toHie mg = concatM $ case mg of-    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->-      [ pure $ locOnly span-      , toHie alts-      ]-    MG{} -> []-    XMatchGroup _ -> []--instance ( ToHie (Context (Located (IdP a)))-         , ToHie (PScoped (LPat a))-         , ToHie (HsPatSynDir a)-         ) => ToHie (Located (PatSynBind a a)) where-    toHie (L sp psb) = concatM $ case psb of-      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->-        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var-        , toHie $ toBind dets-        , toHie $ PS Nothing lhsScope NoScope pat-        , toHie dir-        ]-        where-          lhsScope = combineScopes varScope detScope-          varScope = mkLScope var-          detScope = case dets of-            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args-            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)-            (RecCon r) -> foldr go NoScope r-          go (RecordPatSynField a b) c = combineScopes c-            $ combineScopes (mkLScope a) (mkLScope b)-          detSpan = case detScope of-            LocalScope a -> Just a-            _ -> Nothing-          toBind (PrefixCon args) = PrefixCon $ map (C Use) args-          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)-          toBind (RecCon r) = RecCon $ map (PSC detSpan) r-      XPatSynBind _ -> []--instance ( ToHie (MatchGroup a (LHsExpr a))-         ) => ToHie (HsPatSynDir a) where-  toHie dir = case dir of-    ExplicitBidirectional mg -> toHie mg-    _ -> pure []--instance ( a ~ GhcPass p-         , ToHie body-         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))-         , ToHie (PScoped (LPat a))-         , ToHie (GRHSs a body)-         , Data (Match a body)-         ) => ToHie (LMatch (GhcPass p) body) where-  toHie (L span m ) = concatM $ makeNode m span : case m of-    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->-      [ toHie mctx-      , let rhsScope = mkScope $ grhss_span grhss-          in toHie $ patScopes Nothing rhsScope NoScope pats-      , toHie grhss-      ]-    XMatch _ -> []--instance ( ToHie (Context (Located a))-         ) => ToHie (HsMatchContext a) where-  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name-  toHie (StmtCtxt a) = toHie a-  toHie _ = pure []--instance ( ToHie (HsMatchContext a)-         ) => ToHie (HsStmtContext a) where-  toHie (PatGuard a) = toHie a-  toHie (ParStmtCtxt a) = toHie a-  toHie (TransStmtCtxt a) = toHie a-  toHie _ = pure []--instance ( a ~ GhcPass p-         , ToHie (Context (Located (IdP a)))-         , ToHie (RContext (HsRecFields a (PScoped (LPat a))))-         , ToHie (LHsExpr a)-         , ToHie (TScoped (LHsSigWcType a))-         , ProtectSig a-         , ToHie (TScoped (ProtectedSig a))-         , HasType (LPat a)-         , Data (HsSplice a)-         ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where-  toHie (PS rsp scope pscope lpat@(L ospan opat)) =-    concatM $ getTypeNode lpat : case opat of-      WildPat _ ->-        []-      VarPat _ lname ->-        [ toHie $ C (PatternBind scope pscope rsp) lname-        ]-      LazyPat _ p ->-        [ toHie $ PS rsp scope pscope p-        ]-      AsPat _ lname pat ->-        [ toHie $ C (PatternBind scope-                                 (combineScopes (mkLScope pat) pscope)-                                 rsp)-                    lname-        , toHie $ PS rsp scope pscope pat-        ]-      ParPat _ pat ->-        [ toHie $ PS rsp scope pscope pat-        ]-      BangPat _ pat ->-        [ toHie $ PS rsp scope pscope pat-        ]-      ListPat _ pats ->-        [ toHie $ patScopes rsp scope pscope pats-        ]-      TuplePat _ pats _ ->-        [ toHie $ patScopes rsp scope pscope pats-        ]-      SumPat _ pat _ _ ->-        [ toHie $ PS rsp scope pscope pat-        ]-      ConPatIn c dets ->-        [ toHie $ C Use c-        , toHie $ contextify dets-        ]-      ConPatOut {pat_con = con, pat_args = dets}->-        [ toHie $ C Use $ fmap conLikeName con-        , toHie $ contextify dets-        ]-      ViewPat _ expr pat ->-        [ toHie expr-        , toHie $ PS rsp scope pscope pat-        ]-      SplicePat _ sp ->-        [ toHie $ L ospan sp-        ]-      LitPat _ _ ->-        []-      NPat _ _ _ _ ->-        []-      NPlusKPat _ n _ _ _ _ ->-        [ toHie $ C (PatternBind scope pscope rsp) n-        ]-      SigPat _ pat sig ->-        [ toHie $ PS rsp scope pscope pat-        , let cscope = mkLScope pat in-            toHie $ TS (ResolvedScopes [cscope, scope, pscope])-                       (protectSig @a cscope sig)-              -- See Note [Scoping Rules for SigPat]-        ]-      CoPat _ _ _ _ ->-        []-      XPat _ -> []-    where-      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args-      contextify (InfixCon a b) = InfixCon a' b'-        where [a', b'] = patScopes rsp scope pscope [a,b]-      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r-      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a-        where-          go (RS fscope (L spn (HsRecField lbl pat pun))) =-            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun-          scoped_fds = listScopes pscope fds--instance ( ToHie body-         , ToHie (LGRHS a body)-         , ToHie (RScoped (LHsLocalBinds a))-         ) => ToHie (GRHSs a body) where-  toHie grhs = concatM $ case grhs of-    GRHSs _ grhss binds ->-     [ toHie grhss-     , toHie $ RS (mkScope $ grhss_span grhs) binds-     ]-    XGRHSs _ -> []--instance ( ToHie (Located body)-         , ToHie (RScoped (GuardLStmt a))-         , Data (GRHS a (Located body))-         ) => ToHie (LGRHS a (Located body)) where-  toHie (L span g) = concatM $ makeNode g span : case g of-    GRHS _ guards body ->-      [ toHie $ listScopes (mkLScope body) guards-      , toHie body-      ]-    XGRHS _ -> []--instance ( a ~ GhcPass p-         , ToHie (Context (Located (IdP a)))-         , HasType (LHsExpr a)-         , ToHie (PScoped (LPat a))-         , ToHie (MatchGroup a (LHsExpr a))-         , ToHie (LGRHS a (LHsExpr a))-         , ToHie (RContext (HsRecordBinds a))-         , ToHie (RFContext (Located (AmbiguousFieldOcc a)))-         , ToHie (ArithSeqInfo a)-         , ToHie (LHsCmdTop a)-         , ToHie (RScoped (GuardLStmt a))-         , ToHie (RScoped (LHsLocalBinds a))-         , ToHie (TScoped (LHsWcType (NoGhcTc a)))-         , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))-         , Data (HsExpr a)-         , Data (HsSplice a)-         , Data (HsTupArg a)-         , Data (AmbiguousFieldOcc a)-         , (HasRealDataConName a)-         ) => ToHie (LHsExpr (GhcPass p)) where-  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of-      HsVar _ (L _ var) ->-        [ toHie $ C Use (L mspan var)-             -- Patch up var location since typechecker removes it-        ]-      HsUnboundVar _ _ ->-        []-      HsConLikeOut _ con ->-        [ toHie $ C Use $ L mspan $ conLikeName con-        ]-      HsRecFld _ fld ->-        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)-        ]-      HsOverLabel _ _ _ -> []-      HsIPVar _ _ -> []-      HsOverLit _ _ -> []-      HsLit _ _ -> []-      HsLam _ mg ->-        [ toHie mg-        ]-      HsLamCase _ mg ->-        [ toHie mg-        ]-      HsApp _ a b ->-        [ toHie a-        , toHie b-        ]-      HsAppType _ expr sig ->-        [ toHie expr-        , toHie $ TS (ResolvedScopes []) sig-        ]-      OpApp _ a b c ->-        [ toHie a-        , toHie b-        , toHie c-        ]-      NegApp _ a _ ->-        [ toHie a-        ]-      HsPar _ a ->-        [ toHie a-        ]-      SectionL _ a b ->-        [ toHie a-        , toHie b-        ]-      SectionR _ a b ->-        [ toHie a-        , toHie b-        ]-      ExplicitTuple _ args _ ->-        [ toHie args-        ]-      ExplicitSum _ _ _ expr ->-        [ toHie expr-        ]-      HsCase _ expr matches ->-        [ toHie expr-        , toHie matches-        ]-      HsIf _ _ a b c ->-        [ toHie a-        , toHie b-        , toHie c-        ]-      HsMultiIf _ grhss ->-        [ toHie grhss-        ]-      HsLet _ binds expr ->-        [ toHie $ RS (mkLScope expr) binds-        , toHie expr-        ]-      HsDo _ _ (L ispan stmts) ->-        [ pure $ locOnly ispan-        , toHie $ listScopes NoScope stmts-        ]-      ExplicitList _ _ exprs ->-        [ toHie exprs-        ]-      RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->-        [ toHie $ C Use (getRealDataCon @a mrealcon name)-            -- See Note [Real DataCon Name]-        , toHie $ RC RecFieldAssign $ binds-        ]-      RecordUpd {rupd_expr = expr, rupd_flds = upds}->-        [ toHie expr-        , toHie $ map (RC RecFieldAssign) upds-        ]-      ExprWithTySig _ expr sig ->-        [ toHie expr-        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig-        ]-      ArithSeq _ _ info ->-        [ toHie info-        ]-      HsPragE _ _ expr ->-        [ toHie expr-        ]-      HsProc _ pat cmdtop ->-        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat-        , toHie cmdtop-        ]-      HsStatic _ expr ->-        [ toHie expr-        ]-      HsTick _ _ expr ->-        [ toHie expr-        ]-      HsBinTick _ _ _ expr ->-        [ toHie expr-        ]-      HsWrap _ _ a ->-        [ toHie $ L mspan a-        ]-      HsBracket _ b ->-        [ toHie b-        ]-      HsRnBracketOut _ b p ->-        [ toHie b-        , toHie p-        ]-      HsTcBracketOut _ b p ->-        [ toHie b-        , toHie p-        ]-      HsSpliceE _ x ->-        [ toHie $ L mspan x-        ]-      XExpr _ -> []--instance ( a ~ GhcPass p-         , ToHie (LHsExpr a)-         , Data (HsTupArg a)-         ) => ToHie (LHsTupArg (GhcPass p)) where-  toHie (L span arg) = concatM $ makeNode arg span : case arg of-    Present _ expr ->-      [ toHie expr-      ]-    Missing _ -> []-    XTupArg _ -> []--instance ( a ~ GhcPass p-         , ToHie (PScoped (LPat a))-         , ToHie (LHsExpr a)-         , ToHie (SigContext (LSig a))-         , ToHie (RScoped (LHsLocalBinds a))-         , ToHie (RScoped (ApplicativeArg a))-         , ToHie (Located body)-         , Data (StmtLR a a (Located body))-         , Data (StmtLR a a (Located (HsExpr a)))-         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where-  toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of-      LastStmt _ body _ _ ->-        [ toHie body-        ]-      BindStmt _ pat body _ _ ->-        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat-        , toHie body-        ]-      ApplicativeStmt _ stmts _ ->-        [ concatMapM (toHie . RS scope . snd) stmts-        ]-      BodyStmt _ body _ _ ->-        [ toHie body-        ]-      LetStmt _ binds ->-        [ toHie $ RS scope binds-        ]-      ParStmt _ parstmts _ _ ->-        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->-                          toHie $ listScopes NoScope stmts)-                     parstmts-        ]-      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->-        [ toHie $ listScopes scope stmts-        , toHie using-        , toHie by-        ]-      RecStmt {recS_stmts = stmts} ->-        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts-        ]-      XStmtLR _ -> []--instance ( ToHie (LHsExpr a)-         , ToHie (PScoped (LPat a))-         , ToHie (BindContext (LHsBind a))-         , ToHie (SigContext (LSig a))-         , ToHie (RScoped (HsValBindsLR a a))-         , Data (HsLocalBinds a)-         ) => ToHie (RScoped (LHsLocalBinds a)) where-  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of-      EmptyLocalBinds _ -> []-      HsIPBinds _ _ -> []-      HsValBinds _ valBinds ->-        [ toHie $ RS (combineScopes scope $ mkScope sp)-                      valBinds-        ]-      XHsLocalBindsLR _ -> []--instance ( ToHie (BindContext (LHsBind a))-         , ToHie (SigContext (LSig a))-         , ToHie (RScoped (XXValBindsLR a a))-         ) => ToHie (RScoped (HsValBindsLR a a)) where-  toHie (RS sc v) = concatM $ case v of-    ValBinds _ binds sigs ->-      [ toHie $ fmap (BC RegularBind sc) binds-      , toHie $ fmap (SC (SI BindSig Nothing)) sigs-      ]-    XValBindsLR x -> [ toHie $ RS sc x ]--instance ToHie (RScoped (NHsValBindsLR GhcTc)) where-  toHie (RS sc (NValBinds binds sigs)) = concatM $-    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)-    , toHie $ fmap (SC (SI BindSig Nothing)) sigs-    ]-instance ToHie (RScoped (NHsValBindsLR GhcRn)) where-  toHie (RS sc (NValBinds binds sigs)) = concatM $-    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)-    , toHie $ fmap (SC (SI BindSig Nothing)) sigs-    ]--instance ( ToHie (RContext (LHsRecField a arg))-         ) => ToHie (RContext (HsRecFields a arg)) where-  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields--instance ( ToHie (RFContext (Located label))-         , ToHie arg-         , HasLoc arg-         , Data label-         , Data arg-         ) => ToHie (RContext (LHsRecField' label arg)) where-  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of-    HsRecField label expr _ ->-      [ toHie $ RFC c (getRealSpan $ loc expr) label-      , toHie expr-      ]--removeDefSrcSpan :: Name -> Name-removeDefSrcSpan n = setNameLoc n noSrcSpan--instance ToHie (RFContext (LFieldOcc GhcRn)) where-  toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc name _ ->-      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)-      ]-    XFieldOcc _ -> []--instance ToHie (RFContext (LFieldOcc GhcTc)) where-  toHie (RFC c rhs (L nspan f)) = concatM $ case f of-    FieldOcc var _ ->-      let var' = setVarName var (removeDefSrcSpan $ varName var)-      in [ toHie $ C (RecField c rhs) (L nspan var')-         ]-    XFieldOcc _ -> []--instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where-  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous name _ ->-      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name-      ]-    Ambiguous _name _ ->-      [ ]-    XAmbiguousFieldOcc _ -> []--instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where-  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of-    Unambiguous var _ ->-      let var' = setVarName var (removeDefSrcSpan $ varName var)-      in [ toHie $ C (RecField c rhs) (L nspan var')-         ]-    Ambiguous var _ ->-      let var' = setVarName var (removeDefSrcSpan $ varName var)-      in [ toHie $ C (RecField c rhs) (L nspan var')-         ]-    XAmbiguousFieldOcc _ -> []--instance ( a ~ GhcPass p-         , ToHie (PScoped (LPat a))-         , ToHie (BindContext (LHsBind a))-         , ToHie (LHsExpr a)-         , ToHie (SigContext (LSig a))-         , ToHie (RScoped (HsValBindsLR a a))-         , Data (StmtLR a a (Located (HsExpr a)))-         , Data (HsLocalBinds a)-         ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where-  toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM-    [ toHie $ PS Nothing sc NoScope pat-    , toHie expr-    ]-  toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM-    [ toHie $ listScopes NoScope stmts-    , toHie $ PS Nothing sc NoScope pat-    ]-  toHie (RS _ (XApplicativeArg _)) = pure []--instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where-  toHie (PrefixCon args) = toHie args-  toHie (RecCon rec) = toHie rec-  toHie (InfixCon a b) = concatM [ toHie a, toHie b]--instance ( ToHie (LHsCmd a)-         , Data  (HsCmdTop a)-         ) => ToHie (LHsCmdTop a) where-  toHie (L span top) = concatM $ makeNode top span : case top of-    HsCmdTop _ cmd ->-      [ toHie cmd-      ]-    XCmdTop _ -> []--instance ( a ~ GhcPass p-         , ToHie (PScoped (LPat a))-         , ToHie (BindContext (LHsBind a))-         , ToHie (LHsExpr a)-         , ToHie (MatchGroup a (LHsCmd a))-         , ToHie (SigContext (LSig a))-         , ToHie (RScoped (HsValBindsLR a a))-         , Data (HsCmd a)-         , Data (HsCmdTop a)-         , Data (StmtLR a a (Located (HsCmd a)))-         , Data (HsLocalBinds a)-         , Data (StmtLR a a (Located (HsExpr a)))-         ) => ToHie (LHsCmd (GhcPass p)) where-  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of-      HsCmdArrApp _ a b _ _ ->-        [ toHie a-        , toHie b-        ]-      HsCmdArrForm _ a _ _ cmdtops ->-        [ toHie a-        , toHie cmdtops-        ]-      HsCmdApp _ a b ->-        [ toHie a-        , toHie b-        ]-      HsCmdLam _ mg ->-        [ toHie mg-        ]-      HsCmdPar _ a ->-        [ toHie a-        ]-      HsCmdCase _ expr alts ->-        [ toHie expr-        , toHie alts-        ]-      HsCmdIf _ _ a b c ->-        [ toHie a-        , toHie b-        , toHie c-        ]-      HsCmdLet _ binds cmd' ->-        [ toHie $ RS (mkLScope cmd') binds-        , toHie cmd'-        ]-      HsCmdDo _ (L ispan stmts) ->-        [ pure $ locOnly ispan-        , toHie $ listScopes NoScope stmts-        ]-      HsCmdWrap _ _ _ -> []-      XCmd _ -> []--instance ToHie (TyClGroup GhcRn) where-  toHie TyClGroup{ group_tyclds = classes-                 , group_roles  = roles-                 , group_kisigs = sigs-                 , group_instds = instances } =-    concatM-    [ toHie classes-    , toHie sigs-    , toHie roles-    , toHie instances-    ]-  toHie (XTyClGroup _) = pure []--instance ToHie (LTyClDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      FamDecl {tcdFam = fdecl} ->-        [ toHie (L span fdecl)-        ]-      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->-        [ toHie $ C (Decl SynDec $ getRealSpan span) name-        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars-        , toHie typ-        ]-      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->-        [ toHie $ C (Decl DataDec $ getRealSpan span) name-        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars-        , toHie defn-        ]-        where-          quant_scope = mkLScope $ dd_ctxt defn-          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc-          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn-          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn-          deriv_sc = mkLScope $ dd_derivs defn-      ClassDecl { tcdCtxt = context-                , tcdLName = name-                , tcdTyVars = vars-                , tcdFDs = deps-                , tcdSigs = sigs-                , tcdMeths = meths-                , tcdATs = typs-                , tcdATDefs = deftyps-                } ->-        [ toHie $ C (Decl ClassDec $ getRealSpan span) name-        , toHie context-        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars-        , toHie deps-        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs-        , toHie $ fmap (BC InstanceBind ModuleScope) meths-        , toHie typs-        , concatMapM (pure . locOnly . getLoc) deftyps-        , toHie deftyps-        ]-        where-          context_scope = mkLScope context-          rhs_scope = foldl1' combineScopes $ map mkScope-            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]-      XTyClDecl _ -> []--instance ToHie (LFamilyDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      FamilyDecl _ info name vars _ sig inj ->-        [ toHie $ C (Decl FamDec $ getRealSpan span) name-        , toHie $ TS (ResolvedScopes [rhsSpan]) vars-        , toHie info-        , toHie $ RS injSpan sig-        , toHie inj-        ]-        where-          rhsSpan = sigSpan `combineScopes` injSpan-          sigSpan = mkScope $ getLoc sig-          injSpan = maybe NoScope (mkScope . getLoc) inj-      XFamilyDecl _ -> []--instance ToHie (FamilyInfo GhcRn) where-  toHie (ClosedTypeFamily (Just eqns)) = concatM $-    [ concatMapM (pure . locOnly . getLoc) eqns-    , toHie $ map go eqns-    ]-    where-      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib-  toHie _ = pure []--instance ToHie (RScoped (LFamilyResultSig GhcRn)) where-  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of-      NoSig _ ->-        []-      KindSig _ k ->-        [ toHie k-        ]-      TyVarSig _ bndr ->-        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr-        ]-      XFamilyResultSig _ -> []--instance ToHie (Located (FunDep (Located Name))) where-  toHie (L span fd@(lhs, rhs)) = concatM $-    [ makeNode fd span-    , toHie $ map (C Use) lhs-    , toHie $ map (C Use) rhs-    ]--instance (ToHie rhs, HasLoc rhs)-    => ToHie (TScoped (FamEqn GhcRn rhs)) where-  toHie (TS _ f) = toHie f--instance (ToHie rhs, HasLoc rhs)-    => ToHie (FamEqn GhcRn rhs) where-  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $-    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var-    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs-    , toHie pats-    , toHie rhs-    ]-    where scope = combineScopes patsScope rhsScope-          patsScope = mkScope (loc pats)-          rhsScope = mkScope (loc rhs)-  toHie (XFamEqn _) = pure []--instance ToHie (LInjectivityAnn GhcRn) where-  toHie (L span ann) = concatM $ makeNode ann span : case ann of-      InjectivityAnn lhs rhs ->-        [ toHie $ C Use lhs-        , toHie $ map (C Use) rhs-        ]--instance ToHie (HsDataDefn GhcRn) where-  toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM-    [ toHie ctx-    , toHie mkind-    , toHie cons-    , toHie derivs-    ]-  toHie (XHsDataDefn _) = pure []--instance ToHie (HsDeriving GhcRn) where-  toHie (L span clauses) = concatM-    [ pure $ locOnly span-    , toHie clauses-    ]--instance ToHie (LHsDerivingClause GhcRn) where-  toHie (L span cl) = concatM $ makeNode cl span : case cl of-      HsDerivingClause _ strat (L ispan tys) ->-        [ toHie strat-        , pure $ locOnly ispan-        , toHie $ map (TS (ResolvedScopes [])) tys-        ]-      XHsDerivingClause _ -> []--instance ToHie (Located (DerivStrategy GhcRn)) where-  toHie (L span strat) = concatM $ makeNode strat span : case strat of-      StockStrategy -> []-      AnyclassStrategy -> []-      NewtypeStrategy -> []-      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]--instance ToHie (Located OverlapMode) where-  toHie (L span _) = pure $ locOnly span--instance ToHie (LConDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      ConDeclGADT { con_names = names, con_qvars = qvars-                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->-        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names-        , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars-        , toHie ctx-        , toHie args-        , toHie typ-        ]-        where-          rhsScope = combineScopes argsScope tyScope-          ctxScope = maybe NoScope mkLScope ctx-          argsScope = condecl_scope args-          tyScope = mkLScope typ-      ConDeclH98 { con_name = name, con_ex_tvs = qvars-                 , con_mb_cxt = ctx, con_args = dets } ->-        [ toHie $ C (Decl ConDec $ getRealSpan span) name-        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars-        , toHie ctx-        , toHie dets-        ]-        where-          rhsScope = combineScopes ctxScope argsScope-          ctxScope = maybe NoScope mkLScope ctx-          argsScope = condecl_scope dets-      XConDecl _ -> []-    where condecl_scope args = case args of-            PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs-            InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)-            RecCon x -> mkLScope x--instance ToHie (Located [LConDeclField GhcRn]) where-  toHie (L span decls) = concatM $-    [ pure $ locOnly span-    , toHie decls-    ]--instance ( HasLoc thing-         , ToHie (TScoped thing)-         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where-  toHie (TS sc (HsIB ibrn a)) = concatM $-      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn-      , toHie $ TS sc a-      ]-    where span = loc a-  toHie (TS _ (XHsImplicitBndrs _)) = pure []--instance ( HasLoc thing-         , ToHie (TScoped thing)-         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where-  toHie (TS sc (HsWC names a)) = concatM $-      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names-      , toHie $ TS sc a-      ]-    where span = loc a-  toHie (TS _ (XHsWildCardBndrs _)) = pure []--instance ToHie (LStandaloneKindSig GhcRn) where-  toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]--instance ToHie (StandaloneKindSig GhcRn) where-  toHie sig = concatM $ case sig of-    StandaloneKindSig _ name typ ->-      [ toHie $ C TyDecl name-      , toHie $ TS (ResolvedScopes []) typ-      ]-    XStandaloneKindSig _ -> []--instance ToHie (SigContext (LSig GhcRn)) where-  toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of-      TypeSig _ names typ ->-        [ toHie $ map (C TyDecl) names-        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ-        ]-      PatSynSig _ names typ ->-        [ toHie $ map (C TyDecl) names-        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ-        ]-      ClassOpSig _ _ names typ ->-        [ case styp of-            ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names-            _  -> toHie $ map (C $ TyDecl) names-        , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ-        ]-      IdSig _ _ -> []-      FixSig _ fsig ->-        [ toHie $ L sp fsig-        ]-      InlineSig _ name _ ->-        [ toHie $ (C Use) name-        ]-      SpecSig _ name typs _ ->-        [ toHie $ (C Use) name-        , toHie $ map (TS (ResolvedScopes [])) typs-        ]-      SpecInstSig _ _ typ ->-        [ toHie $ TS (ResolvedScopes []) typ-        ]-      MinimalSig _ _ form ->-        [ toHie form-        ]-      SCCFunSig _ _ name mtxt ->-        [ toHie $ (C Use) name-        , pure $ maybe [] (locOnly . getLoc) mtxt-        ]-      CompleteMatchSig _ _ (L ispan names) typ ->-        [ pure $ locOnly ispan-        , toHie $ map (C Use) names-        , toHie $ fmap (C Use) typ-        ]-      XSig _ -> []--instance ToHie (LHsType GhcRn) where-  toHie x = toHie $ TS (ResolvedScopes []) x--instance ToHie (TScoped (LHsType GhcRn)) where-  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of-      HsForAllTy _ _ bndrs body ->-        [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs-        , toHie body-        ]-      HsQualTy _ ctx body ->-        [ toHie ctx-        , toHie body-        ]-      HsTyVar _ _ var ->-        [ toHie $ C Use var-        ]-      HsAppTy _ a b ->-        [ toHie a-        , toHie b-        ]-      HsAppKindTy _ ty ki ->-        [ toHie ty-        , toHie $ TS (ResolvedScopes []) ki-        ]-      HsFunTy _ a b ->-        [ toHie a-        , toHie b-        ]-      HsListTy _ a ->-        [ toHie a-        ]-      HsTupleTy _ _ tys ->-        [ toHie tys-        ]-      HsSumTy _ tys ->-        [ toHie tys-        ]-      HsOpTy _ a op b ->-        [ toHie a-        , toHie $ C Use op-        , toHie b-        ]-      HsParTy _ a ->-        [ toHie a-        ]-      HsIParamTy _ ip ty ->-        [ toHie ip-        , toHie ty-        ]-      HsKindSig _ a b ->-        [ toHie a-        , toHie b-        ]-      HsSpliceTy _ a ->-        [ toHie $ L span a-        ]-      HsDocTy _ a _ ->-        [ toHie a-        ]-      HsBangTy _ _ ty ->-        [ toHie ty-        ]-      HsRecTy _ fields ->-        [ toHie fields-        ]-      HsExplicitListTy _ _ tys ->-        [ toHie tys-        ]-      HsExplicitTupleTy _ tys ->-        [ toHie tys-        ]-      HsTyLit _ _ -> []-      HsWildCardTy _ -> []-      HsStarTy _ _ -> []-      XHsType _ -> []--instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where-  toHie (HsValArg tm) = toHie tm-  toHie (HsTypeArg _ ty) = toHie ty-  toHie (HsArgPar sp) = pure $ locOnly sp--instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where-  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of-      UserTyVar _ var ->-        [ toHie $ C (TyVarBind sc tsc) var-        ]-      KindedTyVar _ var kind ->-        [ toHie $ C (TyVarBind sc tsc) var-        , toHie kind-        ]-      XTyVarBndr _ -> []--instance ToHie (TScoped (LHsQTyVars GhcRn)) where-  toHie (TS sc (HsQTvs implicits vars)) = concatM $-    [ pure $ bindingsOnly bindings-    , toHie $ tvScopes sc NoScope vars-    ]-    where-      varLoc = loc vars-      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits-  toHie (TS _ (XLHsQTyVars _)) = pure []--instance ToHie (LHsContext GhcRn) where-  toHie (L span tys) = concatM $-      [ pure $ locOnly span-      , toHie tys-      ]--instance ToHie (LConDeclField GhcRn) where-  toHie (L span field) = concatM $ makeNode field span : case field of-      ConDeclField _ fields typ _ ->-        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields-        , toHie typ-        ]-      XConDeclField _ -> []--instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where-  toHie (From expr) = toHie expr-  toHie (FromThen a b) = concatM $-    [ toHie a-    , toHie b-    ]-  toHie (FromTo a b) = concatM $-    [ toHie a-    , toHie b-    ]-  toHie (FromThenTo a b c) = concatM $-    [ toHie a-    , toHie b-    , toHie c-    ]--instance ToHie (LSpliceDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      SpliceDecl _ splice _ ->-        [ toHie splice-        ]-      XSpliceDecl _ -> []--instance ToHie (HsBracket a) where-  toHie _ = pure []--instance ToHie PendingRnSplice where-  toHie _ = pure []--instance ToHie PendingTcSplice where-  toHie _ = pure []--instance ToHie (LBooleanFormula (Located Name)) where-  toHie (L span form) = concatM $ makeNode form span : case form of-      Var a ->-        [ toHie $ C Use a-        ]-      And forms ->-        [ toHie forms-        ]-      Or forms ->-        [ toHie forms-        ]-      Parens f ->-        [ toHie f-        ]--instance ToHie (Located HsIPName) where-  toHie (L span e) = makeNode e span--instance ( ToHie (LHsExpr a)-         , Data (HsSplice a)-         ) => ToHie (Located (HsSplice a)) where-  toHie (L span sp) = concatM $ makeNode sp span : case sp of-      HsTypedSplice _ _ _ expr ->-        [ toHie expr-        ]-      HsUntypedSplice _ _ _ expr ->-        [ toHie expr-        ]-      HsQuasiQuote _ _ _ ispan _ ->-        [ pure $ locOnly ispan-        ]-      HsSpliced _ _ _ ->-        []-      HsSplicedT _ ->-        []-      XSplice _ -> []--instance ToHie (LRoleAnnotDecl GhcRn) where-  toHie (L span annot) = concatM $ makeNode annot span : case annot of-      RoleAnnotDecl _ var roles ->-        [ toHie $ C Use var-        , concatMapM (pure . locOnly . getLoc) roles-        ]-      XRoleAnnotDecl _ -> []--instance ToHie (LInstDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      ClsInstD _ d ->-        [ toHie $ L span d-        ]-      DataFamInstD _ d ->-        [ toHie $ L span d-        ]-      TyFamInstD _ d ->-        [ toHie $ L span d-        ]-      XInstDecl _ -> []--instance ToHie (LClsInstDecl GhcRn) where-  toHie (L span decl) = concatM-    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl-    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl-    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl-    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl-    , toHie $ cid_tyfam_insts decl-    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl-    , toHie $ cid_datafam_insts decl-    , toHie $ cid_overlap_mode decl-    ]--instance ToHie (LDataFamInstDecl GhcRn) where-  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d--instance ToHie (LTyFamInstDecl GhcRn) where-  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d--instance ToHie (Context a)-         => ToHie (PatSynFieldContext (RecordPatSynField a)) where-  toHie (PSC sp (RecordPatSynField a b)) = concatM $-    [ toHie $ C (RecField RecFieldDecl sp) a-    , toHie $ C Use b-    ]--instance ToHie (LDerivDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      DerivDecl _ typ strat overlap ->-        [ toHie $ TS (ResolvedScopes []) typ-        , toHie strat-        , toHie overlap-        ]-      XDerivDecl _ -> []--instance ToHie (LFixitySig GhcRn) where-  toHie (L span sig) = concatM $ makeNode sig span : case sig of-      FixitySig _ vars _ ->-        [ toHie $ map (C Use) vars-        ]-      XFixitySig _ -> []--instance ToHie (LDefaultDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      DefaultDecl _ typs ->-        [ toHie typs-        ]-      XDefaultDecl _ -> []--instance ToHie (LForeignDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->-        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name-        , toHie $ TS (ResolvedScopes []) sig-        , toHie fi-        ]-      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->-        [ toHie $ C Use name-        , toHie $ TS (ResolvedScopes []) sig-        , toHie fe-        ]-      XForeignDecl _ -> []--instance ToHie ForeignImport where-  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $-    [ locOnly a-    , locOnly b-    , locOnly c-    ]--instance ToHie ForeignExport where-  toHie (CExport (L a _) (L b _)) = pure $ concat $-    [ locOnly a-    , locOnly b-    ]--instance ToHie (LWarnDecls GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      Warnings _ _ warnings ->-        [ toHie warnings-        ]-      XWarnDecls _ -> []--instance ToHie (LWarnDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      Warning _ vars _ ->-        [ toHie $ map (C Use) vars-        ]-      XWarnDecl _ -> []--instance ToHie (LAnnDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      HsAnnotation _ _ prov expr ->-        [ toHie prov-        , toHie expr-        ]-      XAnnDecl _ -> []--instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where-  toHie (ValueAnnProvenance a) = toHie $ C Use a-  toHie (TypeAnnProvenance a) = toHie $ C Use a-  toHie ModuleAnnProvenance = pure []--instance ToHie (LRuleDecls GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      HsRules _ _ rules ->-        [ toHie rules-        ]-      XRuleDecls _ -> []--instance ToHie (LRuleDecl GhcRn) where-  toHie (L _ (XRuleDecl _)) = pure []-  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM-        [ makeNode r span-        , pure $ locOnly $ getLoc rname-        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs-        , toHie $ map (RS $ mkScope span) bndrs-        , toHie exprA-        , toHie exprB-        ]-    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc-          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)-          exprA_sc = mkLScope exprA-          exprB_sc = mkLScope exprB--instance ToHie (RScoped (LRuleBndr GhcRn)) where-  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of-      RuleBndr _ var ->-        [ toHie $ C (ValBind RegularBind sc Nothing) var-        ]-      RuleBndrSig _ var typ ->-        [ toHie $ C (ValBind RegularBind sc Nothing) var-        , toHie $ TS (ResolvedScopes [sc]) typ-        ]-      XRuleBndr _ -> []--instance ToHie (LImportDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->-        [ toHie $ IEC Import name-        , toHie $ fmap (IEC ImportAs) as-        , maybe (pure []) goIE hidden-        ]-      XImportDecl _ -> []-    where-      goIE (hiding, (L sp liens)) = concatM $-        [ pure $ locOnly sp-        , toHie $ map (IEC c) liens-        ]-        where-         c = if hiding then ImportHiding else Import--instance ToHie (IEContext (LIE GhcRn)) where-  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of-      IEVar _ n ->-        [ toHie $ IEC c n-        ]-      IEThingAbs _ n ->-        [ toHie $ IEC c n-        ]-      IEThingAll _ n ->-        [ toHie $ IEC c n-        ]-      IEThingWith _ n _ ns flds ->-        [ toHie $ IEC c n-        , toHie $ map (IEC c) ns-        , toHie $ map (IEC c) flds-        ]-      IEModuleContents _ n ->-        [ toHie $ IEC c n-        ]-      IEGroup _ _ _ -> []-      IEDoc _ _ -> []-      IEDocNamed _ _ -> []-      XIE _ -> []--instance ToHie (IEContext (LIEWrappedName Name)) where-  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of-      IEName n ->-        [ toHie $ C (IEThing c) n-        ]-      IEPattern p ->-        [ toHie $ C (IEThing c) p-        ]-      IEType n ->-        [ toHie $ C (IEThing c) n-        ]--instance ToHie (IEContext (Located (FieldLbl Name))) where-  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of-      FieldLabel _ _ n ->-        [ toHie $ C (IEThing c) $ L span n-        ]
− compiler/hieFile/HieBin.hs 
@@ -1,392 +0,0 @@-{--Binary serialization for .hie files.--}-{-# LANGUAGE ScopedTypeVariables #-}-module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where--import GHC.Settings               ( maybeRead )--import Config                     ( cProjectVersion )-import GhcPrelude-import Binary-import BinIface                   ( getDictFastString )-import FastMutInt-import FastString                 ( FastString )-import Module                     ( Module )-import Name-import NameCache-import Outputable-import PrelInfo-import SrcLoc-import UniqSupply                 ( takeUniqFromSupply )-import Unique-import UniqFM--import qualified Data.Array as A-import Data.IORef-import Data.ByteString            ( ByteString )-import qualified Data.ByteString  as BS-import qualified Data.ByteString.Char8 as BSC-import Data.List                  ( mapAccumR )-import Data.Word                  ( Word8, Word32 )-import Control.Monad              ( replicateM, when )-import System.Directory           ( createDirectoryIfMissing )-import System.FilePath            ( takeDirectory )--import HieTypes---- | `Name`'s get converted into `HieName`'s before being written into @.hie@--- files. See 'toHieName' and 'fromHieName' for logic on how to convert between--- these two types.-data HieName-  = ExternalName !Module !OccName !SrcSpan-  | LocalName !OccName !SrcSpan-  | KnownKeyName !Unique-  deriving (Eq)--instance Ord HieName where-  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)-  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)-  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b-    -- Not actually non determinstic as it is a KnownKey-  compare ExternalName{} _ = LT-  compare LocalName{} ExternalName{} = GT-  compare LocalName{} _ = LT-  compare KnownKeyName{} _ = GT--instance Outputable HieName where-  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp-  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp-  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u--hieNameOcc :: HieName -> OccName-hieNameOcc (ExternalName _ occ _) = occ-hieNameOcc (LocalName occ _) = occ-hieNameOcc (KnownKeyName u) =-  case lookupKnownKeyName u of-    Just n -> nameOccName n-    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"-                        (ppr (unpkUnique u))---data HieSymbolTable = HieSymbolTable-  { hie_symtab_next :: !FastMutInt-  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))-  }--data HieDictionary = HieDictionary-  { hie_dict_next :: !FastMutInt -- The next index to use-  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString-  }--initBinMemSize :: Int-initBinMemSize = 1024*1024---- | The header for HIE files - Capital ASCII letters "HIE".-hieMagic :: [Word8]-hieMagic = [72,73,69]--hieMagicLen :: Int-hieMagicLen = length hieMagic--ghcVersion :: ByteString-ghcVersion = BSC.pack cProjectVersion--putBinLine :: BinHandle -> ByteString -> IO ()-putBinLine bh xs = do-  mapM_ (putByte bh) $ BS.unpack xs-  putByte bh 10 -- newline char---- | Write a `HieFile` to the given `FilePath`, with a proper header and--- symbol tables for `Name`s and `FastString`s-writeHieFile :: FilePath -> HieFile -> IO ()-writeHieFile hie_file_path hiefile = do-  bh0 <- openBinMem initBinMemSize--  -- Write the header: hieHeader followed by the-  -- hieVersion and the GHC version used to generate this file-  mapM_ (putByte bh0) hieMagic-  putBinLine bh0 $ BSC.pack $ show hieVersion-  putBinLine bh0 $ ghcVersion--  -- remember where the dictionary pointer will go-  dict_p_p <- tellBin bh0-  put_ bh0 dict_p_p--  -- remember where the symbol table pointer will go-  symtab_p_p <- tellBin bh0-  put_ bh0 symtab_p_p--  -- Make some initial state-  symtab_next <- newFastMutInt-  writeFastMutInt symtab_next 0-  symtab_map <- newIORef emptyUFM-  let hie_symtab = HieSymbolTable {-                      hie_symtab_next = symtab_next,-                      hie_symtab_map  = symtab_map }-  dict_next_ref <- newFastMutInt-  writeFastMutInt dict_next_ref 0-  dict_map_ref <- newIORef emptyUFM-  let hie_dict = HieDictionary {-                      hie_dict_next = dict_next_ref,-                      hie_dict_map  = dict_map_ref }--  -- put the main thing-  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)-                                           (putName hie_symtab)-                                           (putFastString hie_dict)-  put_ bh hiefile--  -- write the symtab pointer at the front of the file-  symtab_p <- tellBin bh-  putAt bh symtab_p_p symtab_p-  seekBin bh symtab_p--  -- write the symbol table itself-  symtab_next' <- readFastMutInt symtab_next-  symtab_map'  <- readIORef symtab_map-  putSymbolTable bh symtab_next' symtab_map'--  -- write the dictionary pointer at the front of the file-  dict_p <- tellBin bh-  putAt bh dict_p_p dict_p-  seekBin bh dict_p--  -- write the dictionary itself-  dict_next <- readFastMutInt dict_next_ref-  dict_map  <- readIORef dict_map_ref-  putDictionary bh dict_next dict_map--  -- and send the result to the file-  createDirectoryIfMissing True (takeDirectory hie_file_path)-  writeBinMem bh hie_file_path-  return ()--data HieFileResult-  = HieFileResult-  { hie_file_result_version :: Integer-  , hie_file_result_ghc_version :: ByteString-  , hie_file_result :: HieFile-  }--type HieHeader = (Integer, ByteString)---- | Read a `HieFile` from a `FilePath`. Can use--- an existing `NameCache`. Allows you to specify--- which versions of hieFile to attempt to read.--- `Left` case returns the failing header versions.-readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache))-readHieFileWithVersion readVersion nc file = do-  bh0 <- readBinMem file--  (hieVersion, ghcVersion) <- readHieFileHeader file bh0--  if readVersion (hieVersion, ghcVersion)-  then do-    (hieFile, nc') <- readHieFileContents bh0 nc-    return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc')-  else return $ Left (hieVersion, ghcVersion)----- | Read a `HieFile` from a `FilePath`. Can use--- an existing `NameCache`.-readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)-readHieFile nc file = do--  bh0 <- readBinMem file--  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0--  -- Check if the versions match-  when (readHieVersion /= hieVersion) $-    panic $ unwords ["readHieFile: hie file versions don't match for file:"-                    , file-                    , "Expected"-                    , show hieVersion-                    , "but got", show readHieVersion-                    ]-  (hieFile, nc') <- readHieFileContents bh0 nc-  return $ (HieFileResult hieVersion ghcVersion hieFile, nc')--readBinLine :: BinHandle -> IO ByteString-readBinLine bh = BS.pack . reverse <$> loop []-  where-    loop acc = do-      char <- get bh :: IO Word8-      if char == 10 -- ASCII newline '\n'-      then return acc-      else loop (char : acc)--readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader-readHieFileHeader file bh0 = do-  -- Read the header-  magic <- replicateM hieMagicLen (get bh0)-  version <- BSC.unpack <$> readBinLine bh0-  case maybeRead version of-    Nothing ->-      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"-                      , show version-                      ]-    Just readHieVersion -> do-      ghcVersion <- readBinLine bh0--      -- Check if the header is valid-      when (magic /= hieMagic) $-        panic $ unwords ["readHieFileHeader: headers don't match for file:"-                        , file-                        , "Expected"-                        , show hieMagic-                        , "but got", show magic-                        ]-      return (readHieVersion, ghcVersion)--readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)-readHieFileContents bh0 nc = do--  dict  <- get_dictionary bh0--  -- read the symbol table so we are capable of reading the actual data-  (bh1, nc') <- do-      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")-                                               (getDictFastString dict)-      (nc', symtab) <- get_symbol_table bh1-      let bh1' = setUserData bh1-               $ newReadState (getSymTabName symtab)-                              (getDictFastString dict)-      return (bh1', nc')--  -- load the actual data-  hiefile <- get bh1-  return (hiefile, nc')-  where-    get_dictionary bin_handle = do-      dict_p <- get bin_handle-      data_p <- tellBin bin_handle-      seekBin bin_handle dict_p-      dict <- getDictionary bin_handle-      seekBin bin_handle data_p-      return dict--    get_symbol_table bh1 = do-      symtab_p <- get bh1-      data_p'  <- tellBin bh1-      seekBin bh1 symtab_p-      (nc', symtab) <- getSymbolTable bh1 nc-      seekBin bh1 data_p'-      return (nc', symtab)--putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()-putFastString HieDictionary { hie_dict_next = j_r,-                              hie_dict_map  = out_r}  bh f-  = do-    out <- readIORef out_r-    let unique = getUnique f-    case lookupUFM out unique of-        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)-        Nothing -> do-           j <- readFastMutInt j_r-           put_ bh (fromIntegral j :: Word32)-           writeFastMutInt j_r (j + 1)-           writeIORef out_r $! addToUFM out unique (j, f)--putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()-putSymbolTable bh next_off symtab = do-  put_ bh next_off-  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))-  mapM_ (putHieName bh) names--getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)-getSymbolTable bh namecache = do-  sz <- get bh-  od_names <- replicateM sz (getHieName bh)-  let arr = A.listArray (0,sz-1) names-      (namecache', names) = mapAccumR fromHieName namecache od_names-  return (namecache', arr)--getSymTabName :: SymbolTable -> BinHandle -> IO Name-getSymTabName st bh = do-  i :: Word32 <- get bh-  return $ st A.! (fromIntegral i)--putName :: HieSymbolTable -> BinHandle -> Name -> IO ()-putName (HieSymbolTable next ref) bh name = do-  symmap <- readIORef ref-  case lookupUFM symmap name of-    Just (off, ExternalName mod occ (UnhelpfulSpan _))-      | isGoodSrcSpan (nameSrcSpan name) -> do-      let hieName = ExternalName mod occ (nameSrcSpan name)-      writeIORef ref $! addToUFM symmap name (off, hieName)-      put_ bh (fromIntegral off :: Word32)-    Just (off, LocalName _occ span)-      | notLocal (toHieName name) || nameSrcSpan name /= span -> do-      writeIORef ref $! addToUFM symmap name (off, toHieName name)-      put_ bh (fromIntegral off :: Word32)-    Just (off, _) -> put_ bh (fromIntegral off :: Word32)-    Nothing -> do-        off <- readFastMutInt next-        writeFastMutInt next (off+1)-        writeIORef ref $! addToUFM symmap name (off, toHieName name)-        put_ bh (fromIntegral off :: Word32)--  where-    notLocal :: HieName -> Bool-    notLocal LocalName{} = False-    notLocal _ = True----- ** Converting to and from `HieName`'s--toHieName :: Name -> HieName-toHieName name-  | isKnownKeyName name = KnownKeyName (nameUnique name)-  | isExternalName name = ExternalName (nameModule name)-                                       (nameOccName name)-                                       (nameSrcSpan name)-  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)--fromHieName :: NameCache -> HieName -> (NameCache, Name)-fromHieName nc (ExternalName mod occ span) =-    let cache = nsNames nc-    in case lookupOrigNameCache cache mod occ of-         Just name -> (nc, name)-         Nothing ->-           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-               name       = mkExternalName uniq mod occ span-               new_cache  = extendNameCache cache mod occ name-           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )-fromHieName nc (LocalName occ span) =-    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-        name       = mkInternalName uniq occ span-    in ( nc{ nsUniqs = us }, name )-fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of-    Nothing -> pprPanic "fromHieName:unknown known-key unique"-                        (ppr (unpkUnique u))-    Just n -> (nc, n)---- ** Reading and writing `HieName`'s--putHieName :: BinHandle -> HieName -> IO ()-putHieName bh (ExternalName mod occ span) = do-  putByte bh 0-  put_ bh (mod, occ, span)-putHieName bh (LocalName occName span) = do-  putByte bh 1-  put_ bh (occName, span)-putHieName bh (KnownKeyName uniq) = do-  putByte bh 2-  put_ bh $ unpkUnique uniq--getHieName :: BinHandle -> IO HieName-getHieName bh = do-  t <- getByte bh-  case t of-    0 -> do-      (modu, occ, span) <- get bh-      return $ ExternalName modu occ span-    1 -> do-      (occ, span) <- get bh-      return $ LocalName occ span-    2 -> do-      (c,i) <- get bh-      return $ KnownKeyName $ mkUnique c i-    _ -> panic "HieBin.getHieName: invalid tag"
− compiler/hieFile/HieDebug.hs 
@@ -1,171 +0,0 @@-{--Functions to validate and check .hie file ASTs generated by GHC.--}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module HieDebug where--import GhcPrelude--import SrcLoc-import Module-import FastString-import Outputable--import HieTypes-import HieBin-import HieUtils-import Name--import qualified Data.Map as M-import qualified Data.Set as S-import Data.Function    ( on )-import Data.List        ( sortOn )-import Data.Foldable    ( toList )--ppHies :: Outputable a => (HieASTs a) -> SDoc-ppHies (HieASTs asts) = M.foldrWithKey go "" asts-  where-    go k a rest = vcat $-      [ "File: " <> ppr k-      , ppHie a-      , rest-      ]--ppHie :: Outputable a => HieAST a -> SDoc-ppHie = go 0-  where-    go n (Node inf sp children) = hang header n rest-      where-        rest = vcat $ map (go (n+2)) children-        header = hsep-          [ "Node"-          , ppr sp-          , ppInfo inf-          ]--ppInfo :: Outputable a => NodeInfo a -> SDoc-ppInfo ni = hsep-  [ ppr $ toList $ nodeAnnotations ni-  , ppr $ nodeType ni-  , ppr $ M.toList $ nodeIdentifiers ni-  ]--type Diff a = a -> a -> [SDoc]--diffFile :: Diff HieFile-diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)--diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))-diffAsts f = diffList (diffAst f) `on` M.elems--diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)-diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =-    infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2-  where-    spanDiff-      | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]-      | otherwise = []-    infoDiff'-      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2-     ++ (diffList diffType `on` nodeType) info1 info2-     ++ (diffIdents `on` nodeIdentifiers) info1 info2-    infoDiff = case infoDiff' of-      [] -> []-      xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)-                           , "and", ppr (nodeIdentifiers info2,span2)-                        , "While comparing"-                        , ppr (normalizeIdents $ nodeIdentifiers info1), "and"-                        , ppr (normalizeIdents $ nodeIdentifiers info2)-                        ]-                  ]--    diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b-    diffIdent (a,b) (c,d) = diffName a c-                         ++ eqDiff b d-    diffName (Right a) (Right b) = case (a,b) of-      (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')-      (LocalName o _, ExternalName _ o' _) -> eqDiff o o'-      _ -> eqDiff a b-    diffName a b = eqDiff a b--type DiffIdent = Either ModuleName HieName--normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]-normalizeIdents = sortOn go . map (first toHieName) . M.toList-  where-    first f (a,b) = (fmap f a, b)-    go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)--diffList :: Diff a -> Diff [a]-diffList f xs ys-  | length xs == length ys = concat $ zipWith f xs ys-  | otherwise = ["length of lists doesn't match"]--eqDiff :: (Outputable a, Eq a) => Diff a-eqDiff a b-  | a == b = []-  | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]--validAst :: HieAST a -> Either SDoc ()-validAst (Node _ span children) = do-  checkContainment children-  checkSorted children-  mapM_ validAst children-  where-    checkSorted [] = return ()-    checkSorted [_] = return ()-    checkSorted (x:y:xs)-      | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)-      | otherwise = Left $ hsep-          [ ppr $ nodeSpan x-          , "is not to the left of"-          , ppr $ nodeSpan y-          ]-    checkContainment [] = return ()-    checkContainment (x:xs)-      | span `containsSpan` (nodeSpan x) = checkContainment xs-      | otherwise = Left $ hsep-          [ ppr $ span-          , "does not contain"-          , ppr $ nodeSpan x-          ]---- | Look for any identifiers which occur outside of their supposed scopes.--- Returns a list of error messages.-validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]-validateScopes mod asts = validScopes-  where-    refMap = generateReferencesMap asts-    -- We use a refmap for most of the computation--    -- Check if all the names occur in their calculated scopes-    validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap-    valid (Left _) _ = []-    valid (Right n) refs = concatMap inScope refs-      where-        mapRef = foldMap getScopeFromContext . identInfo . snd-        scopes = case foldMap mapRef refs of-          Just xs -> xs-          Nothing -> []-        inScope (sp, dets)-          |  (definedInAsts asts n)-          && any isOccurrence (identInfo dets)-          -- We validate scopes for names which are defined locally, and occur-          -- in this span-            = case scopes of-              [] | (nameIsLocalOrFrom mod n-                   && not (isDerivedOccName $ nameOccName n))-                   -- If we don't get any scopes for a local name then its an error.-                   -- We can ignore derived names.-                   -> return $ hsep $-                     [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp-                     , "Doesn't have a calculated scope: ", ppr scopes]-                 | otherwise -> []-              _ -> if any (`scopeContainsSpan` sp) scopes-                   then []-                   else return $ hsep $-                     [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp-                     , "doesn't occur in calculated scope", ppr scopes]-          | otherwise = []
− compiler/hieFile/HieTypes.hs 
@@ -1,509 +0,0 @@-{--Types for the .hie file format are defined here.--For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files--}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-module HieTypes where--import GhcPrelude--import Config-import Binary-import FastString                 ( FastString )-import IfaceType-import Module                     ( ModuleName, Module )-import Name                       ( Name )-import Outputable hiding ( (<>) )-import SrcLoc                     ( RealSrcSpan )-import Avail--import qualified Data.Array as A-import qualified Data.Map as M-import qualified Data.Set as S-import Data.ByteString            ( ByteString )-import Data.Data                  ( Typeable, Data )-import Data.Semigroup             ( Semigroup(..) )-import Data.Word                  ( Word8 )-import Control.Applicative        ( (<|>) )--type Span = RealSrcSpan---- | Current version of @.hie@ files-hieVersion :: Integer-hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer--{- |-GHC builds up a wealth of information about Haskell source as it compiles it.-@.hie@ files are a way of persisting some of this information to disk so that-external tools that need to work with haskell source don't need to parse,-typecheck, and rename all over again. These files contain:--  * a simplified AST--       * nodes are annotated with source positions and types-       * identifiers are annotated with scope information--  * the raw bytes of the initial Haskell source--Besides saving compilation cycles, @.hie@ files also offer a more stable-interface than the GHC API.--}-data HieFile = HieFile-    { hie_hs_file :: FilePath-    -- ^ Initial Haskell source file path--    , hie_module :: Module-    -- ^ The module this HIE file is for--    , hie_types :: A.Array TypeIndex HieTypeFlat-    -- ^ Types referenced in the 'hie_asts'.-    ---    -- See Note [Efficient serialization of redundant type info]--    , hie_asts :: HieASTs TypeIndex-    -- ^ Type-annotated abstract syntax trees--    , hie_exports :: [AvailInfo]-    -- ^ The names that this module exports--    , hie_hs_src :: ByteString-    -- ^ Raw bytes of the initial Haskell source-    }-instance Binary HieFile where-  put_ bh hf = do-    put_ bh $ hie_hs_file hf-    put_ bh $ hie_module hf-    put_ bh $ hie_types hf-    put_ bh $ hie_asts hf-    put_ bh $ hie_exports hf-    put_ bh $ hie_hs_src hf--  get bh = HieFile-    <$> get bh-    <*> get bh-    <*> get bh-    <*> get bh-    <*> get bh-    <*> get bh---{--Note [Efficient serialization of redundant type info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The type information in .hie files is highly repetitive and redundant. For-example, consider the expression--    const True 'a'--There is a lot of shared structure between the types of subterms:--  * const True 'a' ::                 Bool-  * const True     ::         Char -> Bool-  * const          :: Bool -> Char -> Bool--Since all 3 of these types need to be stored in the .hie file, it is worth-making an effort to deduplicate this shared structure. The trick is to define-a new data type that is a flattened version of 'Type':--    data HieType a = HAppTy a a  -- data Type = AppTy Type Type-                   | HFunTy a a  --           | FunTy Type Type-                   | ...--    type TypeIndex = Int--Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',-where the 'TypeIndex's in the 'HieType' are references to other elements of the-array. Types recovered from GHC are deduplicated and stored in this compressed-form with sharing of subtrees.--}--type TypeIndex = Int---- | A flattened version of 'Type'.------ See Note [Efficient serialization of redundant type info]-data HieType a-  = HTyVarTy Name-  | HAppTy a (HieArgs a)-  | HTyConApp IfaceTyCon (HieArgs a)-  | HForAllTy ((Name, a),ArgFlag) a-  | HFunTy  a a-  | HQualTy a a           -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')-  | HLitTy IfaceTyLit-  | HCastTy a-  | HCoercionTy-    deriving (Functor, Foldable, Traversable, Eq)--type HieTypeFlat = HieType TypeIndex---- | Roughly isomorphic to the original core 'Type'.-newtype HieTypeFix = Roll (HieType (HieTypeFix))--instance Binary (HieType TypeIndex) where-  put_ bh (HTyVarTy n) = do-    putByte bh 0-    put_ bh n-  put_ bh (HAppTy a b) = do-    putByte bh 1-    put_ bh a-    put_ bh b-  put_ bh (HTyConApp n xs) = do-    putByte bh 2-    put_ bh n-    put_ bh xs-  put_ bh (HForAllTy bndr a) = do-    putByte bh 3-    put_ bh bndr-    put_ bh a-  put_ bh (HFunTy a b) = do-    putByte bh 4-    put_ bh a-    put_ bh b-  put_ bh (HQualTy a b) = do-    putByte bh 5-    put_ bh a-    put_ bh b-  put_ bh (HLitTy l) = do-    putByte bh 6-    put_ bh l-  put_ bh (HCastTy a) = do-    putByte bh 7-    put_ bh a-  put_ bh (HCoercionTy) = putByte bh 8--  get bh = do-    (t :: Word8) <- get bh-    case t of-      0 -> HTyVarTy <$> get bh-      1 -> HAppTy <$> get bh <*> get bh-      2 -> HTyConApp <$> get bh <*> get bh-      3 -> HForAllTy <$> get bh <*> get bh-      4 -> HFunTy <$> get bh <*> get bh-      5 -> HQualTy <$> get bh <*> get bh-      6 -> HLitTy <$> get bh-      7 -> HCastTy <$> get bh-      8 -> return HCoercionTy-      _ -> panic "Binary (HieArgs Int): invalid tag"----- | A list of type arguments along with their respective visibilities (ie. is--- this an argument that would return 'True' for 'isVisibleArgFlag'?).-newtype HieArgs a = HieArgs [(Bool,a)]-  deriving (Functor, Foldable, Traversable, Eq)--instance Binary (HieArgs TypeIndex) where-  put_ bh (HieArgs xs) = put_ bh xs-  get bh = HieArgs <$> get bh---- | Mapping from filepaths (represented using 'FastString') to the--- corresponding AST-newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }-  deriving (Functor, Foldable, Traversable)--instance Binary (HieASTs TypeIndex) where-  put_ bh asts = put_ bh $ M.toAscList $ getAsts asts-  get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)---data HieAST a =-  Node-    { nodeInfo :: NodeInfo a-    , nodeSpan :: Span-    , nodeChildren :: [HieAST a]-    } deriving (Functor, Foldable, Traversable)--instance Binary (HieAST TypeIndex) where-  put_ bh ast = do-    put_ bh $ nodeInfo ast-    put_ bh $ nodeSpan ast-    put_ bh $ nodeChildren ast--  get bh = Node-    <$> get bh-    <*> get bh-    <*> get bh----- | The information stored in one AST node.------ The type parameter exists to provide flexibility in representation of types--- (see Note [Efficient serialization of redundant type info]).-data NodeInfo a = NodeInfo-    { nodeAnnotations :: S.Set (FastString,FastString)-    -- ^ (name of the AST node constructor, name of the AST node Type)--    , nodeType :: [a]-    -- ^ The Haskell types of this node, if any.--    , nodeIdentifiers :: NodeIdentifiers a-    -- ^ All the identifiers and their details-    } deriving (Functor, Foldable, Traversable)--instance Binary (NodeInfo TypeIndex) where-  put_ bh ni = do-    put_ bh $ S.toAscList $ nodeAnnotations ni-    put_ bh $ nodeType ni-    put_ bh $ M.toList $ nodeIdentifiers ni-  get bh = NodeInfo-    <$> fmap (S.fromDistinctAscList) (get bh)-    <*> get bh-    <*> fmap (M.fromList) (get bh)--type Identifier = Either ModuleName Name--type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)---- | Information associated with every identifier------ We need to include types with identifiers because sometimes multiple--- identifiers occur in the same span(Overloaded Record Fields and so on)-data IdentifierDetails a = IdentifierDetails-  { identType :: Maybe a-  , identInfo :: S.Set ContextInfo-  } deriving (Eq, Functor, Foldable, Traversable)--instance Outputable a => Outputable (IdentifierDetails a) where-  ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)--instance Semigroup (IdentifierDetails a) where-  d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)-                               (S.union (identInfo d1) (identInfo d2))--instance Monoid (IdentifierDetails a) where-  mempty = IdentifierDetails Nothing S.empty--instance Binary (IdentifierDetails TypeIndex) where-  put_ bh dets = do-    put_ bh $ identType dets-    put_ bh $ S.toAscList $ identInfo dets-  get bh =  IdentifierDetails-    <$> get bh-    <*> fmap (S.fromDistinctAscList) (get bh)----- | Different contexts under which identifiers exist-data ContextInfo-  = Use                -- ^ regular variable-  | MatchBind-  | IEThing IEType     -- ^ import/export-  | TyDecl--  -- | Value binding-  | ValBind-      BindType     -- ^ whether or not the binding is in an instance-      Scope        -- ^ scope over which the value is bound-      (Maybe Span) -- ^ span of entire binding--  -- | Pattern binding-  ---  -- This case is tricky because the bound identifier can be used in two-  -- distinct scopes. Consider the following example (with @-XViewPatterns@)-  ---  -- @-  -- do (b, a, (a -> True)) <- bar-  --    foo a-  -- @-  ---  -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and-  -- in the rest of the @do@-block in @foo a@.-  | PatternBind-      Scope        -- ^ scope /in the pattern/ (the variable bound can be used-                   -- further in the pattern)-      Scope        -- ^ rest of the scope outside the pattern-      (Maybe Span) -- ^ span of entire binding--  | ClassTyDecl (Maybe Span)--  -- | Declaration-  | Decl-      DeclType     -- ^ type of declaration-      (Maybe Span) -- ^ span of entire binding--  -- | Type variable-  | TyVarBind Scope TyVarScope--  -- | Record field-  | RecField RecFieldContext (Maybe Span)-    deriving (Eq, Ord, Show)--instance Outputable ContextInfo where-  ppr = text . show--instance Binary ContextInfo where-  put_ bh Use = putByte bh 0-  put_ bh (IEThing t) = do-    putByte bh 1-    put_ bh t-  put_ bh TyDecl = putByte bh 2-  put_ bh (ValBind bt sc msp) = do-    putByte bh 3-    put_ bh bt-    put_ bh sc-    put_ bh msp-  put_ bh (PatternBind a b c) = do-    putByte bh 4-    put_ bh a-    put_ bh b-    put_ bh c-  put_ bh (ClassTyDecl sp) = do-    putByte bh 5-    put_ bh sp-  put_ bh (Decl a b) = do-    putByte bh 6-    put_ bh a-    put_ bh b-  put_ bh (TyVarBind a b) = do-    putByte bh 7-    put_ bh a-    put_ bh b-  put_ bh (RecField a b) = do-    putByte bh 8-    put_ bh a-    put_ bh b-  put_ bh MatchBind = putByte bh 9--  get bh = do-    (t :: Word8) <- get bh-    case t of-      0 -> return Use-      1 -> IEThing <$> get bh-      2 -> return TyDecl-      3 -> ValBind <$> get bh <*> get bh <*> get bh-      4 -> PatternBind <$> get bh <*> get bh <*> get bh-      5 -> ClassTyDecl <$> get bh-      6 -> Decl <$> get bh <*> get bh-      7 -> TyVarBind <$> get bh <*> get bh-      8 -> RecField <$> get bh <*> get bh-      9 -> return MatchBind-      _ -> panic "Binary ContextInfo: invalid tag"----- | Types of imports and exports-data IEType-  = Import-  | ImportAs-  | ImportHiding-  | Export-    deriving (Eq, Enum, Ord, Show)--instance Binary IEType where-  put_ bh b = putByte bh (fromIntegral (fromEnum b))-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))---data RecFieldContext-  = RecFieldDecl-  | RecFieldAssign-  | RecFieldMatch-  | RecFieldOcc-    deriving (Eq, Enum, Ord, Show)--instance Binary RecFieldContext where-  put_ bh b = putByte bh (fromIntegral (fromEnum b))-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))---data BindType-  = RegularBind-  | InstanceBind-    deriving (Eq, Ord, Show, Enum)--instance Binary BindType where-  put_ bh b = putByte bh (fromIntegral (fromEnum b))-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))---data DeclType-  = FamDec     -- ^ type or data family-  | SynDec     -- ^ type synonym-  | DataDec    -- ^ data declaration-  | ConDec     -- ^ constructor declaration-  | PatSynDec  -- ^ pattern synonym-  | ClassDec   -- ^ class declaration-  | InstDec    -- ^ instance declaration-    deriving (Eq, Ord, Show, Enum)--instance Binary DeclType where-  put_ bh b = putByte bh (fromIntegral (fromEnum b))-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))---data Scope-  = NoScope-  | LocalScope Span-  | ModuleScope-    deriving (Eq, Ord, Show, Typeable, Data)--instance Outputable Scope where-  ppr NoScope = text "NoScope"-  ppr (LocalScope sp) = text "LocalScope" <+> ppr sp-  ppr ModuleScope = text "ModuleScope"--instance Binary Scope where-  put_ bh NoScope = putByte bh 0-  put_ bh (LocalScope span) = do-    putByte bh 1-    put_ bh span-  put_ bh ModuleScope = putByte bh 2--  get bh = do-    (t :: Word8) <- get bh-    case t of-      0 -> return NoScope-      1 -> LocalScope <$> get bh-      2 -> return ModuleScope-      _ -> panic "Binary Scope: invalid tag"----- | Scope of a type variable.------ This warrants a data type apart from 'Scope' because of complexities--- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For--- example, consider:------ @--- foo, bar, baz :: forall a. a -> a--- @------ Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we--- need a list of scopes to keep track of this. Furthermore, this list cannot be--- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.------ Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@--- which later gets resolved into a 'ResolvedScopes'.-data TyVarScope-  = ResolvedScopes [Scope]--  -- | Unresolved scopes should never show up in the final @.hie@ file-  | UnresolvedScope-        [Name]        -- ^ names of the definitions over which the scope spans-        (Maybe Span)  -- ^ the location of the instance/class declaration for-                      -- the case where the type variable is declared in a-                      -- method type signature-    deriving (Eq, Ord)--instance Show TyVarScope where-  show (ResolvedScopes sc) = show sc-  show _ = error "UnresolvedScope"--instance Binary TyVarScope where-  put_ bh (ResolvedScopes xs) = do-    putByte bh 0-    put_ bh xs-  put_ bh (UnresolvedScope ns span) = do-    putByte bh 1-    put_ bh ns-    put_ bh span--  get bh = do-    (t :: Word8) <- get bh-    case t of-      0 -> ResolvedScopes <$> get bh-      1 -> UnresolvedScope <$> get bh <*> get bh-      _ -> panic "Binary TyVarScope: invalid tag"
− compiler/hieFile/HieUtils.hs 
@@ -1,455 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-module HieUtils where--import GhcPrelude--import CoreMap-import DynFlags                   ( DynFlags )-import FastString                 ( FastString, mkFastString )-import IfaceType-import Name hiding (varName)-import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )-import SrcLoc-import ToIface-import TyCon-import TyCoRep-import Type-import Var-import VarEnv--import HieTypes--import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.IntMap.Strict as IM-import qualified Data.Array as A-import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )-import Data.Maybe                 ( maybeToList )-import Data.Monoid-import Data.Traversable           ( for )-import Control.Monad.Trans.State.Strict hiding (get)---generateReferencesMap-  :: Foldable f-  => f (HieAST a)-  -> M.Map Identifier [(Span, IdentifierDetails a)]-generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty-  where-    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))-      where-        this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast--renderHieType :: DynFlags -> HieTypeFix -> String-renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty-  where sty = defaultUserStyle df--resolveVisibility :: Type -> [Type] -> [(Bool,Type)]-resolveVisibility kind ty_args-  = go (mkEmptyTCvSubst in_scope) kind ty_args-  where-    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)--    go _   _                   []     = []-    go env ty                  ts-      | Just ty' <- coreView ty-      = go env ty' ts-    go env (ForAllTy (Bndr tv vis) res) (t:ts)-      | isVisibleArgFlag vis = (True , t) : ts'-      | otherwise            = (False, t) : ts'-      where-        ts' = go (extendTvSubst env tv t) res ts--    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps-      = (True,t) : (go env res ts)--    go env (TyVarTy tv) ts-      | Just ki <- lookupTyVar env tv = go env ki ts-    go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded--foldType :: (HieType a -> a) -> HieTypeFix -> a-foldType f (Roll t) = f $ fmap (foldType f) t--hieTypeToIface :: HieTypeFix -> IfaceType-hieTypeToIface = foldType go-  where-    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n-    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)-    go (HLitTy l) = IfaceLitTy l-    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)-                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t-    go (HFunTy a b)     = IfaceFunTy VisArg   a    b-    go (HQualTy pred b) = IfaceFunTy InvisArg pred b-    go (HCastTy a) = a-    go HCoercionTy = IfaceTyVar "<coercion type>"-    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)--    -- This isn't fully faithful - we can't produce the 'Inferred' case-    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs-    hieToIfaceArgs (HieArgs xs) = go' xs-      where-        go' [] = IA_Nil-        go' ((True ,x):xs) = IA_Arg x Required $ go' xs-        go' ((False,x):xs) = IA_Arg x Specified $ go' xs--data HieTypeState-  = HTS-    { tyMap      :: !(TypeMap TypeIndex)-    , htyTable   :: !(IM.IntMap HieTypeFlat)-    , freshIndex :: !TypeIndex-    }--initialHTS :: HieTypeState-initialHTS = HTS emptyTypeMap IM.empty 0--freshTypeIndex :: State HieTypeState TypeIndex-freshTypeIndex = do-  index <- gets freshIndex-  modify' $ \hts -> hts { freshIndex = index+1 }-  return index--compressTypes-  :: HieASTs Type-  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)-compressTypes asts = (a, arr)-  where-    (a, (HTS _ m i)) = flip runState initialHTS $-      for asts $ \typ -> do-        i <- getTypeIndex typ-        return i-    arr = A.array (0,i-1) (IM.toList m)--recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix-recoverFullType i m = go i-  where-    go i = Roll $ fmap go (m A.! i)--getTypeIndex :: Type -> State HieTypeState TypeIndex-getTypeIndex t-  | otherwise = do-      tm <- gets tyMap-      case lookupTypeMap tm t of-        Just i -> return i-        Nothing -> do-          ht <- go t-          extendHTS t ht-  where-    extendHTS t ht = do-      i <- freshTypeIndex-      modify' $ \(HTS tm tt fi) ->-        HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi-      return i--    go (TyVarTy v) = return $ HTyVarTy $ varName v-    go ty@(AppTy _ _) = do-      let (head,args) = splitAppTys ty-          visArgs = HieArgs $ resolveVisibility (typeKind head) args-      ai <- getTypeIndex head-      argsi <- mapM getTypeIndex visArgs-      return $ HAppTy ai argsi-    go (TyConApp f xs) = do-      let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs-      is <- mapM getTypeIndex visArgs-      return $ HTyConApp (toIfaceTyCon f) is-    go (ForAllTy (Bndr v a) t) = do-      k <- getTypeIndex (varType v)-      i <- getTypeIndex t-      return $ HForAllTy ((varName v,k),a) i-    go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do-      ai <- getTypeIndex a-      bi <- getTypeIndex b-      return $ case af of-                 InvisArg -> HQualTy ai bi-                 VisArg   -> HFunTy ai bi-    go (LitTy a) = return $ HLitTy $ toIfaceTyLit a-    go (CastTy t _) = do-      i <- getTypeIndex t-      return $ HCastTy i-    go (CoercionTy _) = return HCoercionTy--resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)-resolveTyVarScopes asts = M.map go asts-  where-    go ast = resolveTyVarScopeLocal ast asts--resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a-resolveTyVarScopeLocal ast asts = go ast-  where-    resolveNameScope dets = dets{identInfo =-      S.map resolveScope (identInfo dets)}-    resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =-      TyVarBind sc $ ResolvedScopes-        [ LocalScope binding-        | name <- names-        , Just binding <- [getNameBinding name asts]-        ]-    resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =-      TyVarBind sc $ ResolvedScopes-        [ LocalScope binding-        | name <- names-        , Just binding <- [getNameBindingInClass name sp asts]-        ]-    resolveScope scope = scope-    go (Node info span children) = Node info' span $ map go children-      where-        info' = info { nodeIdentifiers = idents }-        idents = M.map resolveNameScope $ nodeIdentifiers info--getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span-getNameBinding n asts = do-  (_,msp) <- getNameScopeAndBinding n asts-  msp--getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]-getNameScope n asts = do-  (scopes,_) <- getNameScopeAndBinding n asts-  return scopes--getNameBindingInClass-  :: Name-  -> Span-  -> M.Map FastString (HieAST a)-  -> Maybe Span-getNameBindingInClass n sp asts = do-  ast <- M.lookup (srcSpanFile sp) asts-  getFirst $ foldMap First $ do-    child <- flattenAst ast-    dets <- maybeToList-      $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child-    let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)-    return (getFirst binding)--getNameScopeAndBinding-  :: Name-  -> M.Map FastString (HieAST a)-  -> Maybe ([Scope], Maybe Span)-getNameScopeAndBinding n asts = case nameSrcSpan n of-  RealSrcSpan sp -> do -- @Maybe-    ast <- M.lookup (srcSpanFile sp) asts-    defNode <- selectLargestContainedBy sp ast-    getFirst $ foldMap First $ do -- @[]-      node <- flattenAst defNode-      dets <- maybeToList-        $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node-      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)-      let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)-      return $ Just (scopes, getFirst binding)-  _ -> Nothing--getScopeFromContext :: ContextInfo -> Maybe [Scope]-getScopeFromContext (ValBind _ sc _) = Just [sc]-getScopeFromContext (PatternBind a b _) = Just [a, b]-getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]-getScopeFromContext (Decl _ _) = Just [ModuleScope]-getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs-getScopeFromContext (TyVarBind a _) = Just [a]-getScopeFromContext _ = Nothing--getBindSiteFromContext :: ContextInfo -> Maybe Span-getBindSiteFromContext (ValBind _ _ sp) = sp-getBindSiteFromContext (PatternBind _ _ sp) = sp-getBindSiteFromContext _ = Nothing--flattenAst :: HieAST a -> [HieAST a]-flattenAst n =-  n : concatMap flattenAst (nodeChildren n)--smallestContainingSatisfying-  :: Span-  -> (HieAST a -> Bool)-  -> HieAST a-  -> Maybe (HieAST a)-smallestContainingSatisfying sp cond node-  | nodeSpan node `containsSpan` sp = getFirst $ mconcat-      [ foldMap (First . smallestContainingSatisfying sp cond) $-          nodeChildren node-      , First $ if cond node then Just node else Nothing-      ]-  | sp `containsSpan` nodeSpan node = Nothing-  | otherwise = Nothing--selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)-selectLargestContainedBy sp node-  | sp `containsSpan` nodeSpan node = Just node-  | nodeSpan node `containsSpan` sp =-      getFirst $ foldMap (First . selectLargestContainedBy sp) $-        nodeChildren node-  | otherwise = Nothing--selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)-selectSmallestContaining sp node-  | nodeSpan node `containsSpan` sp = getFirst $ mconcat-      [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node-      , First (Just node)-      ]-  | sp `containsSpan` nodeSpan node = Nothing-  | otherwise = Nothing--definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool-definedInAsts asts n = case nameSrcSpan n of-  RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts-  _ -> False--isOccurrence :: ContextInfo -> Bool-isOccurrence Use = True-isOccurrence _ = False--scopeContainsSpan :: Scope -> Span -> Bool-scopeContainsSpan NoScope _ = False-scopeContainsSpan ModuleScope _ = True-scopeContainsSpan (LocalScope a) b = a `containsSpan` b---- | One must contain the other. Leaf nodes cannot contain anything-combineAst :: HieAST Type -> HieAST Type -> HieAST Type-combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)-  | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)-  | aSpn `containsSpan` bSpn = combineAst b a-combineAst a (Node xs span children) = Node xs span (insertAst a children)---- | Insert an AST in a sorted list of disjoint Asts-insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]-insertAst x = mergeAsts [x]---- | Merge two nodes together.------ Precondition and postcondition: elements in 'nodeType' are ordered.-combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type-(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =-  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)-  where-    mergeSorted :: [Type] -> [Type] -> [Type]-    mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of-                                        LT -> a : mergeSorted as lb-                                        EQ -> a : mergeSorted as bs-                                        GT -> b : mergeSorted la bs-    mergeSorted as [] = as-    mergeSorted [] bs = bs---{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.--In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),-different nodes in an AST tree should either have disjoint spans (in-which case you can say for sure which one comes first) or one span-should be completely contained in the other (in which case the contained-span corresponds to some child node).--However, since Haskell does have position-altering pragmas it /is/-possible for spans to be overlapping. Here is an example of a source file-in which @foozball@ and @quuuuuux@ have overlapping spans:--@-module Baz where--# line 3 "Baz.hs"-foozball :: Int-foozball = 0--# line 3 "Baz.hs"-bar, quuuuuux :: Int-bar = 1-quuuuuux = 2-@--In these cases, we just do our best to produce sensible `HieAST`'s. The blame-should be laid at the feet of whoever wrote the line pragmas in the first place-(usually the C preprocessor...).--}-mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]-mergeAsts xs [] = xs-mergeAsts [] ys = ys-mergeAsts xs@(a:as) ys@(b:bs)-  | span_a `containsSpan`   span_b = mergeAsts (combineAst a b : as) bs-  | span_b `containsSpan`   span_a = mergeAsts as (combineAst a b : bs)-  | span_a `rightOf`        span_b = b : mergeAsts xs bs-  | span_a `leftOf`         span_b = a : mergeAsts as ys--  -- These cases are to work around ASTs that are not fully disjoint-  | span_a `startsRightOf`  span_b = b : mergeAsts as ys-  | otherwise                      = a : mergeAsts as ys-  where-    span_a = nodeSpan a-    span_b = nodeSpan b--rightOf :: Span -> Span -> Bool-rightOf s1 s2-  = (srcSpanStartLine s1, srcSpanStartCol s1)-       >= (srcSpanEndLine s2, srcSpanEndCol s2)-    && (srcSpanFile s1 == srcSpanFile s2)--leftOf :: Span -> Span -> Bool-leftOf s1 s2-  = (srcSpanEndLine s1, srcSpanEndCol s1)-       <= (srcSpanStartLine s2, srcSpanStartCol s2)-    && (srcSpanFile s1 == srcSpanFile s2)--startsRightOf :: Span -> Span -> Bool-startsRightOf s1 s2-  = (srcSpanStartLine s1, srcSpanStartCol s1)-       >= (srcSpanStartLine s2, srcSpanStartCol s2)---- | combines and sorts ASTs using a merge sort-mergeSortAsts :: [HieAST Type] -> [HieAST Type]-mergeSortAsts = go . map pure-  where-    go [] = []-    go [xs] = xs-    go xss = go (mergePairs xss)-    mergePairs [] = []-    mergePairs [xs] = [xs]-    mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss--simpleNodeInfo :: FastString -> FastString -> NodeInfo a-simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty--locOnly :: SrcSpan -> [HieAST a]-locOnly (RealSrcSpan span) =-  [Node e span []]-    where e = NodeInfo S.empty [] M.empty-locOnly _ = []--mkScope :: SrcSpan -> Scope-mkScope (RealSrcSpan sp) = LocalScope sp-mkScope _ = NoScope--mkLScope :: Located a -> Scope-mkLScope = mkScope . getLoc--combineScopes :: Scope -> Scope -> Scope-combineScopes ModuleScope _ = ModuleScope-combineScopes _ ModuleScope = ModuleScope-combineScopes NoScope x = x-combineScopes x NoScope = x-combineScopes (LocalScope a) (LocalScope b) =-  mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)--{-# INLINEABLE makeNode #-}-makeNode-  :: (Applicative m, Data a)-  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')-  -> SrcSpan                 -- ^ return an empty list if this is unhelpful-  -> m [HieAST b]-makeNode x spn = pure $ case spn of-  RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]-  _ -> []-  where-    cons = mkFastString . show . toConstr $ x-    typ = mkFastString . show . typeRepTyCon . typeOf $ x--{-# INLINEABLE makeTypeNode #-}-makeTypeNode-  :: (Applicative m, Data a)-  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')-  -> SrcSpan                 -- ^ return an empty list if this is unhelpful-  -> Type                    -- ^ type to associate with the node-  -> m [HieAST Type]-makeTypeNode x spn etyp = pure $ case spn of-  RealSrcSpan span ->-    [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]-  _ -> []-  where-    cons = mkFastString . show . toConstr $ x-    typ = mkFastString . show . typeRepTyCon . typeOf $ x
− compiler/iface/BinIface.hs 
@@ -1,435 +0,0 @@-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}-------  (c) The University of Glasgow 2002-2006-----{-# OPTIONS_GHC -O2 #-}--- We always optimise this, otherwise performance of a non-optimised--- compiler is severely affected---- | Binary interface file support.-module BinIface (-        -- * Public API for interface file serialisation-        writeBinIface,-        readBinIface,-        getSymtabName,-        getDictFastString,-        CheckHiWay(..),-        TraceBinIFaceReading(..),-        getWithUserData,-        putWithUserData,--        -- * Internal serialisation functions-        getSymbolTable,-        putName,-        putDictionary,-        putFastString,-        putSymbolTable,-        BinSymbolTable(..),-        BinDictionary(..)--    ) where--#include "HsVersions.h"--import GhcPrelude--import TcRnMonad-import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )-import IfaceEnv-import HscTypes-import Module-import Name-import DynFlags-import UniqFM-import UniqSupply-import Panic-import Binary-import SrcLoc-import ErrUtils-import FastMutInt-import Unique-import Outputable-import NameCache-import GHC.Platform-import FastString-import Constants-import Util--import Data.Array-import Data.Array.ST-import Data.Array.Unsafe-import Data.Bits-import Data.Char-import Data.Word-import Data.IORef-import Data.Foldable-import Control.Monad-import Control.Monad.ST-import Control.Monad.Trans.Class-import qualified Control.Monad.Trans.State.Strict as State---- ------------------------------------------------------------------------------ Reading and writing binary interface files-----data CheckHiWay = CheckHiWay | IgnoreHiWay-    deriving Eq--data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading-    deriving Eq---- | Read an interface file-readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath-             -> TcRnIf a b ModIface-readBinIface checkHiWay traceBinIFaceReading hi_path = do-    ncu <- mkNameCacheUpdater-    dflags <- getDynFlags-    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu--readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath-              -> NameCacheUpdater-              -> IO ModIface-readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do-    let printer :: SDoc -> IO ()-        printer = case traceBinIFaceReading of-                      TraceBinIFaceReading -> \sd ->-                          putLogMsg dflags-                                    NoReason-                                    SevOutput-                                    noSrcSpan-                                    (defaultDumpStyle dflags)-                                    sd-                      QuietBinIFaceReading -> \_ -> return ()--        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()-        wantedGot what wanted got ppr' =-            printer (text what <> text ": " <>-                     vcat [text "Wanted " <> ppr' wanted <> text ",",-                           text "got    " <> ppr' got])--        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()-        errorOnMismatch what wanted got =-            -- This will be caught by readIface which will emit an error-            -- msg containing the iface module name.-            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError-                         (what ++ " (wanted " ++ show wanted-                               ++ ", got "    ++ show got ++ ")")-    bh <- Binary.readBinMem hi_path--    -- Read the magic number to check that this really is a GHC .hi file-    -- (This magic number does not change when we change-    --  GHC interface file format)-    magic <- get bh-    wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr-    errorOnMismatch "magic number mismatch: old/corrupt interface file?"-        (binaryInterfaceMagic dflags) magic--    -- Note [dummy iface field]-    -- read a dummy 32/64 bit value.  This field used to hold the-    -- dictionary pointer in old interface file formats, but now-    -- the dictionary pointer is after the version (where it-    -- should be).  Also, the serialisation of value of type "Bin-    -- a" used to depend on the word size of the machine, now they-    -- are always 32 bits.-    if wORD_SIZE dflags == 4-        then do _ <- Binary.get bh :: IO Word32; return ()-        else do _ <- Binary.get bh :: IO Word64; return ()--    -- Check the interface file version and ways.-    check_ver  <- get bh-    let our_ver = show hiVersion-    wantedGot "Version" our_ver check_ver text-    errorOnMismatch "mismatched interface file versions" our_ver check_ver--    check_way <- get bh-    let way_descr = getWayDescr dflags-    wantedGot "Way" way_descr check_way ppr-    when (checkHiWay == CheckHiWay) $-        errorOnMismatch "mismatched interface file ways" way_descr check_way-    getWithUserData ncu bh----- | This performs a get action after reading the dictionary and symbol--- table. It is necessary to run this before trying to deserialise any--- Names or FastStrings.-getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a-getWithUserData ncu bh = do-    -- Read the dictionary-    -- The next word in the file is a pointer to where the dictionary is-    -- (probably at the end of the file)-    dict_p <- Binary.get bh-    data_p <- tellBin bh          -- Remember where we are now-    seekBin bh dict_p-    dict   <- getDictionary bh-    seekBin bh data_p             -- Back to where we were before--    -- Initialise the user-data field of bh-    bh <- do-        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")-                                                     (getDictFastString dict)-        symtab_p <- Binary.get bh     -- Get the symtab ptr-        data_p <- tellBin bh          -- Remember where we are now-        seekBin bh symtab_p-        symtab <- getSymbolTable bh ncu-        seekBin bh data_p             -- Back to where we were before--        -- It is only now that we know how to get a Name-        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)-                                               (getDictFastString dict)--    -- Read the interface file-    get bh---- | Write an interface file-writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()-writeBinIface dflags hi_path mod_iface = do-    bh <- openBinMem initBinMemSize-    put_ bh (binaryInterfaceMagic dflags)--   -- dummy 32/64-bit field before the version/way for-   -- compatibility with older interface file formats.-   -- See Note [dummy iface field] above.-    if wORD_SIZE dflags == 4-        then Binary.put_ bh (0 :: Word32)-        else Binary.put_ bh (0 :: Word64)--    -- The version and way descriptor go next-    put_ bh (show hiVersion)-    let way_descr = getWayDescr dflags-    put_  bh way_descr---    putWithUserData (debugTraceMsg dflags 3) bh mod_iface-    -- And send the result to the file-    writeBinMem bh hi_path---- | Put a piece of data with an initialised `UserData` field. This--- is necessary if you want to serialise Names or FastStrings.--- It also writes a symbol table and the dictionary.--- This segment should be read using `getWithUserData`.-putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()-putWithUserData log_action bh payload = do-    -- Remember where the dictionary pointer will go-    dict_p_p <- tellBin bh-    -- Placeholder for ptr to dictionary-    put_ bh dict_p_p--    -- Remember where the symbol table pointer will go-    symtab_p_p <- tellBin bh-    put_ bh symtab_p_p-    -- Make some initial state-    symtab_next <- newFastMutInt-    writeFastMutInt symtab_next 0-    symtab_map <- newIORef emptyUFM-    let bin_symtab = BinSymbolTable {-                         bin_symtab_next = symtab_next,-                         bin_symtab_map  = symtab_map }-    dict_next_ref <- newFastMutInt-    writeFastMutInt dict_next_ref 0-    dict_map_ref <- newIORef emptyUFM-    let bin_dict = BinDictionary {-                       bin_dict_next = dict_next_ref,-                       bin_dict_map  = dict_map_ref }--    -- Put the main thing,-    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)-                                                  (putName bin_dict bin_symtab)-                                                  (putFastString bin_dict)-    put_ bh payload--    -- Write the symtab pointer at the front of the file-    symtab_p <- tellBin bh        -- This is where the symtab will start-    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder-    seekBin bh symtab_p           -- Seek back to the end of the file--    -- Write the symbol table itself-    symtab_next <- readFastMutInt symtab_next-    symtab_map  <- readIORef symtab_map-    putSymbolTable bh symtab_next symtab_map-    log_action (text "writeBinIface:" <+> int symtab_next-                                <+> text "Names")--    -- NB. write the dictionary after the symbol table, because-    -- writing the symbol table may create more dictionary entries.--    -- Write the dictionary pointer at the front of the file-    dict_p <- tellBin bh          -- This is where the dictionary will start-    putAt bh dict_p_p dict_p      -- Fill in the placeholder-    seekBin bh dict_p             -- Seek back to the end of the file--    -- Write the dictionary itself-    dict_next <- readFastMutInt dict_next_ref-    dict_map  <- readIORef dict_map_ref-    putDictionary bh dict_next dict_map-    log_action (text "writeBinIface:" <+> int dict_next-                                <+> text "dict entries")------ | Initial ram buffer to allocate for writing interface files-initBinMemSize :: Int-initBinMemSize = 1024 * 1024--binaryInterfaceMagic :: DynFlags -> Word32-binaryInterfaceMagic dflags- | target32Bit (targetPlatform dflags) = 0x1face- | otherwise                           = 0x1face64----- -------------------------------------------------------------------------------- The symbol table-----putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()-putSymbolTable bh next_off symtab = do-    put_ bh next_off-    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))-      -- It's OK to use nonDetEltsUFM here because the elements have-      -- indices that array uses to create order-    mapM_ (\n -> serialiseName bh n symtab) names--getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable-getSymbolTable bh ncu = do-    sz <- get bh-    od_names <- sequence (replicate sz (get bh))-    updateNameCache ncu $ \namecache ->-        runST $ flip State.evalStateT namecache $ do-            mut_arr <- lift $ newSTArray_ (0, sz-1)-            for_ (zip [0..] od_names) $ \(i, odn) -> do-                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn-                lift $ writeArray mut_arr i n-                State.put nc-            arr <- lift $ unsafeFreeze mut_arr-            namecache' <- State.get-            return (namecache', arr)-  where-    -- This binding is required because the type of newArray_ cannot be inferred-    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)-    newSTArray_ = newArray_--type OnDiskName = (UnitId, ModuleName, OccName)--fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)-fromOnDiskName nc (pid, mod_name, occ) =-    let mod   = mkModule pid mod_name-        cache = nsNames nc-    in case lookupOrigNameCache cache  mod occ of-           Just name -> (nc, name)-           Nothing   ->-               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)-                   name       = mkExternalName uniq mod occ noSrcSpan-                   new_cache  = extendNameCache cache mod occ name-               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )--serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()-serialiseName bh name _ = do-    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name-    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)----- Note [Symbol table representation of names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ An occurrence of a name in an interface file is serialized as a single 32-bit--- word. The format of this word is:---  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx---   A normal name. x is an index into the symbol table---  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy---   A known-key name. x is the Unique's Char, y is the int part. We assume that---   all known-key uniques fit in this space. This is asserted by---   PrelInfo.knownKeyNamesOkay.------ During serialization we check for known-key things using isKnownKeyName.--- During deserialization we use lookupKnownKeyName to get from the unique back--- to its corresponding Name.----- See Note [Symbol table representation of names]-putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()-putName _dict BinSymbolTable{-               bin_symtab_map = symtab_map_ref,-               bin_symtab_next = symtab_next }-        bh name-  | isKnownKeyName name-  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits-  = -- ASSERT(u < 2^(22 :: Int))-    put_ bh (0x80000000-             .|. (fromIntegral (ord c) `shiftL` 22)-             .|. (fromIntegral u :: Word32))--  | otherwise-  = do symtab_map <- readIORef symtab_map_ref-       case lookupUFM symtab_map name of-         Just (off,_) -> put_ bh (fromIntegral off :: Word32)-         Nothing -> do-            off <- readFastMutInt symtab_next-            -- MASSERT(off < 2^(30 :: Int))-            writeFastMutInt symtab_next (off+1)-            writeIORef symtab_map_ref-                $! addToUFM symtab_map name (off,name)-            put_ bh (fromIntegral off :: Word32)---- See Note [Symbol table representation of names]-getSymtabName :: NameCacheUpdater-              -> Dictionary -> SymbolTable-              -> BinHandle -> IO Name-getSymtabName _ncu _dict symtab bh = do-    i :: Word32 <- get bh-    case i .&. 0xC0000000 of-      0x00000000 -> return $! symtab ! fromIntegral i--      0x80000000 ->-        let-          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))-          ix  = fromIntegral i .&. 0x003FFFFF-          u   = mkUnique tag ix-        in-          return $! case lookupKnownKeyName u of-                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"-                                          (ppr i $$ ppr (unpkUnique u))-                      Just n  -> n--      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)--data BinSymbolTable = BinSymbolTable {-        bin_symtab_next :: !FastMutInt, -- The next index to use-        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))-                                -- indexed by Name-  }--putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()-putFastString dict bh fs = allocateFastString dict fs >>= put_ bh--allocateFastString :: BinDictionary -> FastString -> IO Word32-allocateFastString BinDictionary { bin_dict_next = j_r,-                                   bin_dict_map  = out_r} f = do-    out <- readIORef out_r-    let uniq = getUnique f-    case lookupUFM out uniq of-        Just (j, _)  -> return (fromIntegral j :: Word32)-        Nothing -> do-           j <- readFastMutInt j_r-           writeFastMutInt j_r (j + 1)-           writeIORef out_r $! addToUFM out uniq (j, f)-           return (fromIntegral j :: Word32)--getDictFastString :: Dictionary -> BinHandle -> IO FastString-getDictFastString dict bh = do-    j <- get bh-    return $! (dict ! fromIntegral (j :: Word32))--data BinDictionary = BinDictionary {-        bin_dict_next :: !FastMutInt, -- The next index to use-        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))-                                -- indexed by FastString-  }--getWayDescr :: DynFlags -> String-getWayDescr dflags-  | platformUnregisterised (targetPlatform dflags) = 'u':tag-  | otherwise                                      =     tag-  where tag = buildTag dflags-        -- if this is an unregisterised build, make sure our interfaces-        -- can't be used by a registerised build.
compiler/iface/BuildTyCl.hs view
@@ -5,6 +5,8 @@  {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module BuildTyCl (         buildDataCon,         buildPatSyn,@@ -17,7 +19,7 @@  import GhcPrelude -import IfaceEnv+import GHC.Iface.Env import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) import TysWiredIn( isCTupleTyConName ) import TysPrim ( voidPrimTy )@@ -78,7 +80,7 @@      etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can     etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty-    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface+    etad_rhs   :: Type     -- See Note [Tricky iface loop] in GHC.Iface.Load     (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty      eta_reduce :: [TyVar]       -- Reversed@@ -386,7 +388,7 @@                   -> TcRnIf m n Name            -- Implicit name -- Called in BuildTyCl to allocate the implicit binders of type/class decls -- For source type/class decls, this is the first occurrence--- For iface ones, the LoadIface has already allocated a suitable name in the cache+-- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache newImplicitBinder base_name mk_sys_occ   = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
− compiler/iface/IfaceEnv.hs 
@@ -1,298 +0,0 @@--- (c) The University of Glasgow 2002-2006--{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}--module IfaceEnv (-        newGlobalBinder, newInteractiveBinder,-        externaliseName,-        lookupIfaceTop,-        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,-        newIfaceName, newIfaceNames,-        extendIfaceIdEnv, extendIfaceTyVarEnv,-        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,-        lookupIfaceTyVar, extendIfaceEnvs,-        setNameModule,--        ifaceExportNames,--        -- Name-cache stuff-        allocateGlobalBinder, updNameCacheTc,-        mkNameCacheUpdater, NameCacheUpdater(..),-   ) where--#include "HsVersions.h"--import GhcPrelude--import TcRnMonad-import HscTypes-import Type-import Var-import Name-import Avail-import Module-import FastString-import FastStringEnv-import IfaceType-import NameCache-import UniqSupply-import SrcLoc--import Outputable-import Data.List     ( partition )--{--*********************************************************-*                                                      *-        Allocating new Names in the Name Cache-*                                                      *-*********************************************************--See Also: Note [The Name Cache] in NameCache--}--newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name--- Used for source code and interface files, to make the--- Name for a thing, given its Module and OccName--- See Note [The Name Cache]------ The cache may already already have a binding for this thing,--- because we may have seen an occurrence before, but now is the--- moment when we know its Module and SrcLoc in their full glory--newGlobalBinder mod occ loc-  = do { name <- updNameCacheTc mod occ $ \name_cache ->-                 allocateGlobalBinder name_cache mod occ loc-       ; traceIf (text "newGlobalBinder" <+>-                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))-       ; return name }--newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name--- Works in the IO monad, and gets the Module--- from the interactive context-newInteractiveBinder hsc_env occ loc- = do { let mod = icInteractiveModule (hsc_IC hsc_env)-       ; updNameCacheIO hsc_env mod occ $ \name_cache ->-         allocateGlobalBinder name_cache mod occ loc }--allocateGlobalBinder-  :: NameCache-  -> Module -> OccName -> SrcSpan-  -> (NameCache, Name)--- See Note [The Name Cache]-allocateGlobalBinder name_supply mod occ loc-  = case lookupOrigNameCache (nsNames name_supply) mod occ of-        -- A hit in the cache!  We are at the binding site of the name.-        -- This is the moment when we know the SrcLoc-        -- of the Name, so we set this field in the Name we return.-        ---        -- Then (bogus) multiple bindings of the same Name-        -- get different SrcLocs can be reported as such.-        ---        -- Possible other reason: it might be in the cache because we-        --      encountered an occurrence before the binding site for an-        --      implicitly-imported Name.  Perhaps the current SrcLoc is-        --      better... but not really: it'll still just say 'imported'-        ---        -- IMPORTANT: Don't mess with wired-in names.-        --            Their wired-in-ness is in their NameSort-        --            and their Module is correct.--        Just name | isWiredInName name-                  -> (name_supply, name)-                  | otherwise-                  -> (new_name_supply, name')-                  where-                    uniq            = nameUnique name-                    name'           = mkExternalName uniq mod occ loc-                                      -- name' is like name, but with the right SrcSpan-                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'-                    new_name_supply = name_supply {nsNames = new_cache}--        -- Miss in the cache!-        -- Build a completely new Name, and put it in the cache-        _ -> (new_name_supply, name)-                  where-                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)-                    name            = mkExternalName uniq mod occ loc-                    new_cache       = extendNameCache (nsNames name_supply) mod occ name-                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}--ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]-ifaceExportNames exports = return exports---- | A function that atomically updates the name cache given a modifier--- function.  The second result of the modifier function will be the result--- of the IO action.-newtype NameCacheUpdater-      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }--mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater-mkNameCacheUpdater = do { hsc_env <- getTopEnv-                        ; let !ncRef = hsc_NC hsc_env-                        ; return (NCU (updNameCache ncRef)) }--updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))-               -> TcRnIf a b c-updNameCacheTc mod occ upd_fn = do {-    hsc_env <- getTopEnv-  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }---updNameCacheIO ::  HscEnv -> Module -> OccName-               -> (NameCache -> (NameCache, c))-               -> IO c-updNameCacheIO hsc_env mod occ upd_fn = do {--    -- First ensure that mod and occ are evaluated-    -- If not, chaos can ensue:-    --      we read the name-cache-    --      then pull on mod (say)-    --      which does some stuff that modifies the name cache-    -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)--    mod `seq` occ `seq` return ()-  ; updNameCache (hsc_NC hsc_env) upd_fn }---{--************************************************************************-*                                                                      *-                Name cache access-*                                                                      *-************************************************************************--}---- | Look up the 'Name' for a given 'Module' and 'OccName'.--- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad--- and 'Module' is simply that of the 'ModIface' you are typechecking.-lookupOrig :: Module -> OccName -> TcRnIf a b Name-lookupOrig mod occ-  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)--        ; updNameCacheTc mod occ $ lookupNameCache mod occ }--lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name-lookupOrigIO hsc_env mod occ-  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ--lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)--- Lookup up the (Module,OccName) in the NameCache--- If you find it, return it; if not, allocate a fresh original name and extend--- the NameCache.--- Reason: this may the first occurrence of (say) Foo.bar we have encountered.--- If we need to explore its value we will load Foo.hi; but meanwhile all we--- need is a Name for it.-lookupNameCache mod occ name_cache =-  case lookupOrigNameCache (nsNames name_cache) mod occ of {-    Just name -> (name_cache, name);-    Nothing   ->-        case takeUniqFromSupply (nsUniqs name_cache) of {-          (uniq, us) ->-              let-                name      = mkExternalName uniq mod occ noSrcSpan-                new_cache = extendNameCache (nsNames name_cache) mod occ name-              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}--externaliseName :: Module -> Name -> TcRnIf m n Name--- Take an Internal Name and make it an External one,--- with the same unique-externaliseName mod name-  = do { let occ = nameOccName name-             loc = nameSrcSpan name-             uniq = nameUnique name-       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder-       ; updNameCacheTc mod occ $ \ ns ->-         let name' = mkExternalName uniq mod occ loc-             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }-         in (ns', name') }---- | Set the 'Module' of a 'Name'.-setNameModule :: Maybe Module -> Name -> TcRnIf m n Name-setNameModule Nothing n = return n-setNameModule (Just m) n =-    newGlobalBinder m (nameOccName n) (nameSrcSpan n)--{--************************************************************************-*                                                                      *-                Type variables and local Ids-*                                                                      *-************************************************************************--}--tcIfaceLclId :: FastString -> IfL Id-tcIfaceLclId occ-  = do  { lcl <- getLclEnv-        ; case (lookupFsEnv (if_id_env lcl) occ) of-            Just ty_var -> return ty_var-            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)-        }--extendIfaceIdEnv :: [Id] -> IfL a -> IfL a-extendIfaceIdEnv ids thing_inside-  = do  { env <- getLclEnv-        ; let { id_env' = extendFsEnvList (if_id_env env) pairs-              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }-        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }---tcIfaceTyVar :: FastString -> IfL TyVar-tcIfaceTyVar occ-  = do  { lcl <- getLclEnv-        ; case (lookupFsEnv (if_tv_env lcl) occ) of-            Just ty_var -> return ty_var-            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)-        }--lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)-lookupIfaceTyVar (occ, _)-  = do  { lcl <- getLclEnv-        ; return (lookupFsEnv (if_tv_env lcl) occ) }--lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)-lookupIfaceVar (IfaceIdBndr (occ, _))-  = do  { lcl <- getLclEnv-        ; return (lookupFsEnv (if_id_env lcl) occ) }-lookupIfaceVar (IfaceTvBndr (occ, _))-  = do  { lcl <- getLclEnv-        ; return (lookupFsEnv (if_tv_env lcl) occ) }--extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a-extendIfaceTyVarEnv tyvars thing_inside-  = do  { env <- getLclEnv-        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs-              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }-        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }--extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a-extendIfaceEnvs tcvs thing_inside-  = extendIfaceTyVarEnv tvs $-    extendIfaceIdEnv    cvs $-    thing_inside-  where-    (tvs, cvs) = partition isTyVar tcvs--{--************************************************************************-*                                                                      *-                Getting from RdrNames to Names-*                                                                      *-************************************************************************--}---- | Look up a top-level name from the current Iface module-lookupIfaceTop :: OccName -> IfL Name-lookupIfaceTop occ-  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }--newIfaceName :: OccName -> IfL Name-newIfaceName occ-  = do  { uniq <- newUnique-        ; return $! mkInternalName uniq occ noSrcSpan }--newIfaceNames :: [OccName] -> IfL [Name]-newIfaceNames occs-  = do  { uniqs <- newUniqueSupply-        ; return [ mkInternalName uniq occ noSrcSpan-                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
− compiler/iface/IfaceEnv.hs-boot 
@@ -1,9 +0,0 @@-module IfaceEnv where--import Module-import OccName-import TcRnMonad-import Name-import SrcLoc--newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
− compiler/iface/LoadIface.hs 
@@ -1,1289 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Loading interface files--}--{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module LoadIface (-        -- Importing one thing-        tcLookupImported_maybe, importDecl,-        checkWiredInTyCon, ifCheckWiredInThing,--        -- RnM/TcM functions-        loadModuleInterface, loadModuleInterfaces,-        loadSrcInterface, loadSrcInterface_maybe,-        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,--        -- IfM functions-        loadInterface,-        loadSysInterface, loadUserInterface, loadPluginInterface,-        findAndReadIface, readIface,    -- Used when reading the module's old interface-        loadDecls,      -- Should move to TcIface and be renamed-        initExternalPackageState,-        moduleFreeHolesPrecise,-        needWiredInHomeIface, loadWiredInHomeIface,--        pprModIfaceSimple,-        ifaceStats, pprModIface, showIface-   ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,-                                 tcIfaceFamInst,-                                 tcIfaceAnnotations, tcIfaceCompleteSigs )--import DynFlags-import IfaceSyn-import IfaceEnv-import HscTypes--import BasicTypes hiding (SuccessFlag(..))-import TcRnMonad--import Constants-import PrelNames-import PrelInfo-import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )-import MkId     ( seqId )-import TysPrim  ( funTyConName )-import Rules-import TyCon-import Annotations-import InstEnv-import FamInstEnv-import Name-import NameEnv-import Avail-import Module-import Maybes-import ErrUtils-import Finder-import UniqFM-import SrcLoc-import Outputable-import BinIface-import Panic-import Util-import FastString-import Fingerprint-import Hooks-import FieldLabel-import RnModIface-import UniqDSet-import Plugins--import Control.Monad-import Control.Exception-import Data.IORef-import System.FilePath--{--************************************************************************-*                                                                      *-*      tcImportDecl is the key function for "faulting in"              *-*      imported things-*                                                                      *-************************************************************************--The main idea is this.  We are chugging along type-checking source code, and-find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find-it in the EPS type envt.  So it-        1 loads GHC.Base.hi-        2 gets the decl for GHC.Base.map-        3 typechecks it via tcIfaceDecl-        4 and adds it to the type env in the EPS--Note that DURING STEP 4, we may find that map's type mentions a type-constructor that also--Notice that for imported things we read the current version from the EPS-mutable variable.  This is important in situations like-        ...$(e1)...$(e2)...-where the code that e1 expands to might import some defns that-also turn out to be needed by the code that e2 expands to.--}--tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)--- Returns (Failed err) if we can't find the interface file for the thing-tcLookupImported_maybe name-  = do  { hsc_env <- getTopEnv-        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)-        ; case mb_thing of-            Just thing -> return (Succeeded thing)-            Nothing    -> tcImportDecl_maybe name }--tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)--- Entry point for *source-code* uses of importDecl-tcImportDecl_maybe name-  | Just thing <- wiredInNameTyThing_maybe name-  = do  { when (needWiredInHomeIface thing)-               (initIfaceTcRn (loadWiredInHomeIface name))-                -- See Note [Loading instances for wired-in things]-        ; return (Succeeded thing) }-  | otherwise-  = initIfaceTcRn (importDecl name)--importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)--- Get the TyThing for this Name from an interface file--- It's not a wired-in thing -- the caller caught that-importDecl name-  = ASSERT( not (isWiredInName name) )-    do  { traceIf nd_doc--        -- Load the interface, which should populate the PTE-        ; mb_iface <- ASSERT2( isExternalName name, ppr name )-                      loadInterface nd_doc (nameModule name) ImportBySystem-        ; case mb_iface of {-                Failed err_msg  -> return (Failed err_msg) ;-                Succeeded _ -> do--        -- Now look it up again; this time we should find it-        { eps <- getEps-        ; case lookupTypeEnv (eps_PTE eps) name of-            Just thing -> return $ Succeeded thing-            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)-                                    $$ not_found_msg-                          in return $ Failed doc-    }}}-  where-    nd_doc = text "Need decl for" <+> ppr name-    not_found_msg = hang (text "Can't find interface-file declaration for" <+>-                                pprNameSpace (nameNameSpace name) <+> ppr name)-                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",-                                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))-      where-        is_interesting thing = nameModule name == nameModule (getName thing)---{--************************************************************************-*                                                                      *-           Checks for wired-in things-*                                                                      *-************************************************************************--Note [Loading instances for wired-in things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to make sure that we have at least *read* the interface files-for any module with an instance decl or RULE that we might want.--* If the instance decl is an orphan, we have a whole separate mechanism-  (loadOrphanModules)--* If the instance decl is not an orphan, then the act of looking at the-  TyCon or Class will force in the defining module for the-  TyCon/Class, and hence the instance decl--* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;-  but we must make sure we read its interface in case it has instances or-  rules.  That is what LoadIface.loadWiredInHomeIface does.  It's called-  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}--* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There-  are some wired-in Ids, but we don't want to load their interfaces. For-  example, Control.Exception.Base.recSelError is wired in, but that module-  is compiled late in the base library, and we don't want to force it to-  load before it's been compiled!--All of this is done by the type checker. The renamer plays no role.-(It used to, but no longer.)--}--checkWiredInTyCon :: TyCon -> TcM ()--- Ensure that the home module of the TyCon (and hence its instances)--- are loaded. See Note [Loading instances for wired-in things]--- It might not be a wired-in tycon (see the calls in TcUnify),--- in which case this is a no-op.-checkWiredInTyCon tc-  | not (isWiredInName tc_name)-  = return ()-  | otherwise-  = do  { mod <- getModule-        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)-        ; ASSERT( isExternalName tc_name )-          when (mod /= nameModule tc_name)-               (initIfaceTcRn (loadWiredInHomeIface tc_name))-                -- Don't look for (non-existent) Float.hi when-                -- compiling Float.hs, which mentions Float of course-                -- A bit yukky to call initIfaceTcRn here-        }-  where-    tc_name = tyConName tc--ifCheckWiredInThing :: TyThing -> IfL ()--- Even though we are in an interface file, we want to make--- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)--- Ditto want to ensure that RULES are loaded too--- See Note [Loading instances for wired-in things]-ifCheckWiredInThing thing-  = do  { mod <- getIfModule-                -- Check whether we are typechecking the interface for this-                -- very module.  E.g when compiling the base library in --make mode-                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in-                -- the HPT, so without the test we'll demand-load it into the PIT!-                -- C.f. the same test in checkWiredInTyCon above-        ; let name = getName thing-        ; ASSERT2( isExternalName name, ppr name )-          when (needWiredInHomeIface thing && mod /= nameModule name)-               (loadWiredInHomeIface name) }--needWiredInHomeIface :: TyThing -> Bool--- Only for TyCons; see Note [Loading instances for wired-in things]-needWiredInHomeIface (ATyCon {}) = True-needWiredInHomeIface _           = False---{--************************************************************************-*                                                                      *-        loadSrcInterface, loadOrphanModules, loadInterfaceForName--                These three are called from TcM-land-*                                                                      *-************************************************************************--}---- | Load the interface corresponding to an @import@ directive in--- source code.  On a failure, fail in the monad with an error message.-loadSrcInterface :: SDoc-                 -> ModuleName-                 -> IsBootInterface     -- {-# SOURCE #-} ?-                 -> Maybe FastString    -- "package", if any-                 -> RnM ModIface--loadSrcInterface doc mod want_boot maybe_pkg-  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg-       ; case res of-           Failed err      -> failWithTc err-           Succeeded iface -> return iface }---- | Like 'loadSrcInterface', but returns a 'MaybeErr'.-loadSrcInterface_maybe :: SDoc-                       -> ModuleName-                       -> IsBootInterface     -- {-# SOURCE #-} ?-                       -> Maybe FastString    -- "package", if any-                       -> RnM (MaybeErr MsgDoc ModIface)--loadSrcInterface_maybe doc mod want_boot maybe_pkg-  -- We must first find which Module this import refers to.  This involves-  -- calling the Finder, which as a side effect will search the filesystem-  -- and create a ModLocation.  If successful, loadIface will read the-  -- interface; it will call the Finder again, but the ModLocation will be-  -- cached from the first search.-  = do { hsc_env <- getTopEnv-       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg-       ; case res of-           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)-           -- TODO: Make sure this error message is good-           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }---- | Load interface directly for a fully qualified 'Module'.  (This is a fairly--- rare operation, but in particular it is used to load orphan modules--- in order to pull their instances into the global package table and to--- handle some operations in GHCi).-loadModuleInterface :: SDoc -> Module -> TcM ModIface-loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)---- | Load interfaces for a collection of modules.-loadModuleInterfaces :: SDoc -> [Module] -> TcM ()-loadModuleInterfaces doc mods-  | null mods = return ()-  | otherwise = initIfaceTcRn (mapM_ load mods)-  where-    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod---- | Loads the interface for a given Name.--- Should only be called for an imported name;--- otherwise loadSysInterface may not find the interface-loadInterfaceForName :: SDoc -> Name -> TcRn ModIface-loadInterfaceForName doc name-  = do { when debugIsOn $  -- Check pre-condition-         do { this_mod <- getModule-            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }-      ; ASSERT2( isExternalName name, ppr name )-        initIfaceTcRn $ loadSysInterface doc (nameModule name) }---- | Only loads the interface for external non-local names.-loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)-loadInterfaceForNameMaybe doc name-  = do { this_mod <- getModule-       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)-         then return Nothing-         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))-       }---- | Loads the interface for a given Module.-loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface-loadInterfaceForModule doc m-  = do-    -- Should not be called with this module-    when debugIsOn $ do-      this_mod <- getModule-      MASSERT2( this_mod /= m, ppr m <+> parens doc )-    initIfaceTcRn $ loadSysInterface doc m--{--*********************************************************-*                                                      *-                loadInterface--        The main function to load an interface-        for an imported module, and put it in-        the External Package State-*                                                      *-*********************************************************--}---- | An 'IfM' function to load the home interface for a wired-in thing,--- so that we're sure that we see its instance declarations and rules--- See Note [Loading instances for wired-in things]-loadWiredInHomeIface :: Name -> IfM lcl ()-loadWiredInHomeIface name-  = ASSERT( isWiredInName name )-    do _ <- loadSysInterface doc (nameModule name); return ()-  where-    doc = text "Need home interface for wired-in thing" <+> ppr name----------------------- | Loads a system interface and throws an exception if it fails-loadSysInterface :: SDoc -> Module -> IfM lcl ModIface-loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem----------------------- | Loads a user interface and throws an exception if it fails. The first parameter indicates--- whether we should import the boot variant of the module-loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface-loadUserInterface is_boot doc mod_name-  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)--loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface-loadPluginInterface doc mod_name-  = loadInterfaceWithException doc mod_name ImportByPlugin----------------------- | A wrapper for 'loadInterface' that throws an exception if it fails-loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface-loadInterfaceWithException doc mod_name where_from-  = withException (loadInterface doc mod_name where_from)---------------------loadInterface :: SDoc -> Module -> WhereFrom-              -> IfM lcl (MaybeErr MsgDoc ModIface)---- loadInterface looks in both the HPT and PIT for the required interface--- If not found, it loads it, and puts it in the PIT (always).---- If it can't find a suitable interface file, we---      a) modify the PackageIfaceTable to have an empty entry---              (to avoid repeated complaints)---      b) return (Left message)------ It's not necessarily an error for there not to be an interface--- file -- perhaps the module has changed, and that interface--- is no longer used--loadInterface doc_str mod from-  | isHoleModule mod-  -- Hole modules get special treatment-  = do dflags <- getDynFlags-       -- Redo search for our local hole module-       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from-  | otherwise-  = withTimingSilentD (text "loading interface") (pure ()) $-    do  {       -- Read the state-          (eps,hpt) <- getEpsAndHpt-        ; gbl_env <- getGblEnv--        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)--                -- Check whether we have the interface already-        ; dflags <- getDynFlags-        ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {-            Just iface-                -> return (Succeeded iface) ;   -- Already loaded-                        -- The (src_imp == mi_boot iface) test checks that the already-loaded-                        -- interface isn't a boot iface.  This can conceivably happen,-                        -- if an earlier import had a before we got to real imports.   I think.-            _ -> do {--        -- READ THE MODULE IN-        ; read_result <- case (wantHiBootFile dflags eps mod from) of-                           Failed err             -> return (Failed err)-                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod-        ; case read_result of {-            Failed err -> do-                { let fake_iface = emptyFullModIface mod--                ; updateEps_ $ \eps ->-                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }-                        -- Not found, so add an empty iface to-                        -- the EPS map so that we don't look again--                ; return (Failed err) } ;--        -- Found and parsed!-        -- We used to have a sanity check here that looked for:-        --  * System importing ..-        --  * a home package module ..-        --  * that we know nothing about (mb_dep == Nothing)!-        ---        -- But this is no longer valid because thNameToGhcName allows users to-        -- cause the system to load arbitrary interfaces (by supplying an appropriate-        -- Template Haskell original-name).-            Succeeded (iface, loc) ->-        let-            loc_doc = text loc-        in-        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do--        dontLeakTheHPT $ do--        --      Load the new ModIface into the External Package State-        -- Even home-package interfaces loaded by loadInterface-        --      (which only happens in OneShot mode; in Batch/Interactive-        --      mode, home-package modules are loaded one by one into the HPT)-        -- are put in the EPS.-        ---        -- The main thing is to add the ModIface to the PIT, but-        -- we also take the-        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,-        -- out of the ModIface and put them into the big EPS pools--        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined-        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).-        --     If we do loadExport first the wrong info gets into the cache (unless we-        --      explicitly tag each export which seems a bit of a bore)--        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas-        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)-        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)-        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)-        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)-        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)-        ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)--        ; let { final_iface = iface {-                                mi_decls     = panic "No mi_decls in PIT",-                                mi_insts     = panic "No mi_insts in PIT",-                                mi_fam_insts = panic "No mi_fam_insts in PIT",-                                mi_rules     = panic "No mi_rules in PIT",-                                mi_anns      = panic "No mi_anns in PIT"-                              }-               }--        ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod-                            -- Warn warn against an EPS-updating import-                            -- of one's own boot file! (one-shot only)-                            -- See Note [Loading your own hi-boot file]-                            -- in MkIface.--        ; WARN( bad_boot, ppr mod )-          updateEps_  $ \ eps ->-           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface-                then eps-           else if bad_boot-                -- See Note [Loading your own hi-boot file]-                then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }-           else-                eps {-                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,-                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,-                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)-                                                        new_eps_rules,-                  eps_complete_matches-                                   = extendCompleteMatchMap-                                         (eps_complete_matches eps)-                                         new_eps_complete_sigs,-                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)-                                                       new_eps_insts,-                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)-                                                          new_eps_fam_insts,-                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)-                                                      new_eps_anns,-                  eps_mod_fam_inst_env-                                   = let-                                       fam_inst_env =-                                         extendFamInstEnvList emptyFamInstEnv-                                                              new_eps_fam_insts-                                     in-                                     extendModuleEnv (eps_mod_fam_inst_env eps)-                                                     mod-                                                     fam_inst_env,-                  eps_stats        = addEpsInStats (eps_stats eps)-                                                   (length new_eps_decls)-                                                   (length new_eps_insts)-                                                   (length new_eps_rules) }--        ; -- invoke plugins-          res <- withPlugins dflags interfaceLoadAction final_iface-        ; return (Succeeded res)-    }}}}--{- Note [Loading your own hi-boot file]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally speaking, when compiling module M, we should not-load M.hi boot into the EPS.  After all, we are very shortly-going to have full information about M.  Moreover, see-Note [Do not update EPS with your own hi-boot] in MkIface.--But there is a HORRIBLE HACK here.--* At the end of tcRnImports, we call checkFamInstConsistency to-  check consistency of imported type-family instances-  See Note [The type family instance consistency story] in FamInst--* Alas, those instances may refer to data types defined in M,-  if there is a M.hs-boot.--* And that means we end up loading M.hi-boot, because those-  data types are not yet in the type environment.--But in this weird case, /all/ we need is the types. We don't need-instances, rules etc.  And if we put the instances in the EPS-we get "duplicate instance" warnings when we compile the "real"-instance in M itself.  Hence the strange business of just updateing-the eps_PTE.--This really happens in practice.  The module HsExpr.hs gets-"duplicate instance" errors if this hack is not present.--This is a mess.---Note [HPT space leak] (#15111)-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In IfL, we defer some work until it is demanded using forkM, such-as building TyThings from IfaceDecls. These thunks are stored in-the ExternalPackageState, and they might never be poked.  If we're-not careful, these thunks will capture the state of the loaded-program when we read an interface file, and retain all that data-for ever.--Therefore, when loading a package interface file , we use a "clean"-version of the HscEnv with all the data about the currently loaded-program stripped out. Most of the fields can be panics because-we'll never read them, but hsc_HPT needs to be empty because this-interface will cause other interfaces to be loaded recursively, and-when looking up those interfaces we use the HPT in loadInterface.-We know that none of the interfaces below here can refer to-home-package modules however, so it's safe for the HPT to be empty.--}--dontLeakTheHPT :: IfL a -> IfL a-dontLeakTheHPT thing_inside = do-  let-    cleanTopEnv HscEnv{..} =-       let-         -- wrinkle: when we're typechecking in --backpack mode, the-         -- instantiation of a signature might reside in the HPT, so-         -- this case breaks the assumption that EPS interfaces only-         -- refer to other EPS interfaces. We can detect when we're in-         -- typechecking-only mode by using hscTarget==HscNothing, and-         -- in that case we don't empty the HPT.  (admittedly this is-         -- a bit of a hack, better suggestions welcome). A number of-         -- tests in testsuite/tests/backpack break without this-         -- tweak.-         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT-              | otherwise = emptyHomePackageTable-       in-       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"-              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"-              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"-              ,  hsc_HPT          = hpt-              , .. }--  updTopEnv cleanTopEnv $ do-  !_ <- getTopEnv        -- force the updTopEnv-  thing_inside----- | Returns @True@ if a 'ModIface' comes from an external package.--- In this case, we should NOT load it into the EPS; the entities--- should instead come from the local merged signature interface.-is_external_sig :: DynFlags -> ModIface -> Bool-is_external_sig dflags iface =-    -- It's a signature iface...-    mi_semantic_module iface /= mi_module iface &&-    -- and it's not from the local package-    moduleUnitId (mi_module iface) /= thisPackage dflags---- | This is an improved version of 'findAndReadIface' which can also--- handle the case when a user requests @p[A=<B>]:M@ but we only--- have an interface for @p[A=<A>]:M@ (the indefinite interface.--- If we are not trying to build code, we load the interface we have,--- *instantiating it* according to how the holes are specified.--- (Of course, if we're actually building code, this is a hard error.)------ In the presence of holes, 'computeInterface' has an important invariant:--- to load module M, its set of transitively reachable requirements must--- have an up-to-date local hi file for that requirement.  Note that if--- we are loading the interface of a requirement, this does not--- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require--- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless--- we are actually typechecking p.)-computeInterface ::-       SDoc -> IsBootInterface -> Module-    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))-computeInterface doc_str hi_boot_file mod0 = do-    MASSERT( not (isHoleModule mod0) )-    dflags <- getDynFlags-    case splitModuleInsts mod0 of-        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do-            r <- findAndReadIface doc_str imod mod0 hi_boot_file-            case r of-                Succeeded (iface0, path) -> do-                    hsc_env <- getTopEnv-                    r <- liftIO $-                        rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))-                                   Nothing iface0-                    case r of-                        Right x -> return (Succeeded (x, path))-                        Left errs -> liftIO . throwIO . mkSrcErr $ errs-                Failed err -> return (Failed err)-        (mod, _) ->-            findAndReadIface doc_str mod mod0 hi_boot_file---- | Compute the signatures which must be compiled in order to--- load the interface for a 'Module'.  The output of this function--- is always a subset of 'moduleFreeHoles'; it is more precise--- because in signature @p[A=<A>,B=<B>]:B@, although the free holes--- are A and B, B might not depend on A at all!------ If this is invoked on a signature, this does NOT include the--- signature itself; e.g. precise free module holes of--- @p[A=<A>,B=<B>]:B@ never includes B.-moduleFreeHolesPrecise-    :: SDoc -> Module-    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))-moduleFreeHolesPrecise doc_str mod- | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)- | otherwise =-   case splitModuleInsts mod of-    (imod, Just indef) -> do-        let insts = indefUnitIdInsts (indefModuleUnitId indef)-        traceIf (text "Considering whether to load" <+> ppr mod <+>-                 text "to compute precise free module holes")-        (eps, hpt) <- getEpsAndHpt-        case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of-            Just r -> return (Succeeded r)-            Nothing -> readAndCache imod insts-    (_, Nothing) -> return (Succeeded emptyUniqDSet)-  where-    tryEpsAndHpt eps hpt =-        fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod)-    tryDepsCache eps imod insts =-        case lookupInstalledModuleEnv (eps_free_holes eps) imod of-            Just ifhs  -> Just (renameFreeHoles ifhs insts)-            _otherwise -> Nothing-    readAndCache imod insts = do-        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False-        case mb_iface of-            Succeeded (iface, _) -> do-                let ifhs = mi_free_holes iface-                -- Cache it-                updateEps_ (\eps ->-                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })-                return (Succeeded (renameFreeHoles ifhs insts))-            Failed err -> return (Failed err)--wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom-               -> MaybeErr MsgDoc IsBootInterface--- Figure out whether we want Foo.hi or Foo.hi-boot-wantHiBootFile dflags eps mod from-  = case from of-       ImportByUser usr_boot-          | usr_boot && not this_package-          -> Failed (badSourceImport mod)-          | otherwise -> Succeeded usr_boot--       ImportByPlugin-          -> Succeeded False--       ImportBySystem-          | not this_package   -- If the module to be imported is not from this package-          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed-                               -- on the ModuleName of *home-package* modules only.-                               -- We never import boot modules from other packages!--          | otherwise-          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of-                Just (_, is_boot) -> Succeeded is_boot-                Nothing           -> Succeeded False-                     -- The boot-ness of the requested interface,-                     -- based on the dependencies in directly-imported modules-  where-    this_package = thisPackage dflags == moduleUnitId mod--badSourceImport :: Module -> SDoc-badSourceImport mod-  = hang (text "You cannot {-# SOURCE #-} import a module from another package")-       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")-          <+> quotes (ppr (moduleUnitId mod)))----------------------------------------------------------      Loading type/class/value decls--- We pass the full Module name here, replete with--- its package info, so that we can build a Name for--- each binder with the right package info in it--- All subsequent lookups, including crucially lookups during typechecking--- the declaration itself, will find the fully-glorious Name------ We handle ATs specially.  They are not main declarations, but also not--- implicit things (in particular, adding them to `implicitTyThings' would mess--- things up in the renaming/type checking of source programs).--------------------------------------------------------addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv-addDeclsToPTE pte things = extendNameEnvList pte things--loadDecls :: Bool-          -> [(Fingerprint, IfaceDecl)]-          -> IfL [(Name,TyThing)]-loadDecls ignore_prags ver_decls-   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls-        ; return (concat thingss)-        }--loadDecl :: Bool                    -- Don't load pragmas into the decl pool-          -> (Fingerprint, IfaceDecl)-          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the-                                    -- TyThings are forkM'd thunks-loadDecl ignore_prags (_version, decl)-  = do  {       -- Populate the name cache with final versions of all-                -- the names associated with the decl-          let main_name = ifName decl--        -- Typecheck the thing, lazily-        -- NB. Firstly, the laziness is there in case we never need the-        -- declaration (in one-shot mode), and secondly it is there so that-        -- we don't look up the occurrence of a name before calling mk_new_bndr-        -- on the binder.  This is important because we must get the right name-        -- which includes its nameParent.--        ; thing <- forkM doc $ do { bumpDeclStats main_name-                                  ; tcIfaceDecl ignore_prags decl }--        -- Populate the type environment with the implicitTyThings too.-        ---        -- Note [Tricky iface loop]-        -- ~~~~~~~~~~~~~~~~~~~~~~~~-        -- Summary: The delicate point here is that 'mini-env' must be-        -- buildable from 'thing' without demanding any of the things-        -- 'forkM'd by tcIfaceDecl.-        ---        -- In more detail: Consider the example-        --      data T a = MkT { x :: T a }-        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]-        -- (plus their workers, wrappers, coercions etc etc)-        ---        -- We want to return an environment-        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]-        -- (where the "MkT" is the *Name* associated with MkT, etc.)-        ---        -- We do this by mapping the implicit_names to the associated-        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and-        -- implicitTyThings, we can use getOccName on the implicit-        -- TyThings to make this association: each Name's OccName should-        -- be the OccName of exactly one implicitTyThing.  So the key is-        -- to define a "mini-env"-        ---        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]-        -- where the 'MkT' here is the *OccName* associated with MkT.-        ---        -- However, there is a subtlety: due to how type checking needs-        -- to be staged, we can't poke on the forkM'd thunks inside the-        -- implicitTyThings while building this mini-env.-        -- If we poke these thunks too early, two problems could happen:-        --    (1) When processing mutually recursive modules across-        --        hs-boot boundaries, poking too early will do the-        --        type-checking before the recursive knot has been tied,-        --        so things will be type-checked in the wrong-        --        environment, and necessary variables won't be in-        --        scope.-        ---        --    (2) Looking up one OccName in the mini_env will cause-        --        others to be looked up, which might cause that-        --        original one to be looked up again, and hence loop.-        ---        -- The code below works because of the following invariant:-        -- getOccName on a TyThing does not force the suspended type-        -- checks in order to extract the name. For example, we don't-        -- poke on the "T a" type of <selector x> on the way to-        -- extracting <selector x>'s OccName. Of course, there is no-        -- reason in principle why getting the OccName should force the-        -- thunks, but this means we need to be careful in-        -- implicitTyThings and its helper functions.-        ---        -- All a bit too finely-balanced for my liking.--        -- This mini-env and lookup function mediates between the-        --'Name's n and the map from 'OccName's to the implicit TyThings-        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]-              lookup n = case lookupOccEnv mini_env (getOccName n) of-                           Just thing -> thing-                           Nothing    ->-                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))--        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)----         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)-        ; return $ (main_name, thing) :-                      -- uses the invariant that implicit_names and-                      -- implicitTyThings are bijective-                      [(n, lookup n) | n <- implicit_names]-        }-  where-    doc = text "Declaration for" <+> ppr (ifName decl)--bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used-bumpDeclStats name-  = do  { traceIf (text "Loading decl for" <+> ppr name)-        ; updateEps_ (\eps -> let stats = eps_stats eps-                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })-        }--{--*********************************************************-*                                                      *-\subsection{Reading an interface file}-*                                                      *-*********************************************************--Note [Home module load error]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the sought-for interface is in the current package (as determined-by -package-name flag) then it jolly well should already be in the HPT-because we process home-package modules in dependency order.  (Except-in one-shot mode; see notes with hsc_HPT decl in HscTypes).--It is possible (though hard) to get this error through user behaviour.-  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,-    Q2, with Q2 importing Q1)-  * We compile both packages.-  * Now we edit package Q so that it somehow depends on P-  * Now recompile Q with --make (without recompiling P).-  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2-    is a home-package module which is not yet in the HPT!  Disaster.--This actually happened with P=base, Q=ghc-prim, via the AMP warnings.-See #8320.--}--findAndReadIface :: SDoc-                 -- The unique identifier of the on-disk module we're-                 -- looking for-                 -> InstalledModule-                 -- The *actual* module we're looking for.  We use-                 -- this to check the consistency of the requirements-                 -- of the module we read out.-                 -> Module-                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file-                                        -- False <=> Look for .hi file-                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))-        -- Nothing <=> file not found, or unreadable, or illegible-        -- Just x  <=> successfully found and parsed--        -- It *doesn't* add an error to the monad, because-        -- sometimes it's ok to fail... see notes with loadInterface-findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file-  = do traceIf (sep [hsep [text "Reading",-                           if hi_boot_file-                             then text "[boot]"-                             else Outputable.empty,-                           text "interface for",-                           ppr mod <> semi],-                     nest 4 (text "reason:" <+> doc_str)])--       -- Check for GHC.Prim, and return its static interface-       -- TODO: make this check a function-       if mod `installedModuleEq` gHC_PRIM-           then do-               iface <- getHooked ghcPrimIfaceHook ghcPrimIface-               return (Succeeded (iface,-                                   "<built in interface for GHC.Prim>"))-           else do-               dflags <- getDynFlags-               -- Look for the file-               hsc_env <- getTopEnv-               mb_found <- liftIO (findExactModule hsc_env mod)-               case mb_found of-                   InstalledFound loc mod -> do-                       -- Found file, so read it-                       let file_path = addBootSuffix_maybe hi_boot_file-                                                           (ml_hi_file loc)--                       -- See Note [Home module load error]-                       if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&-                          not (isOneShot (ghcMode dflags))-                           then return (Failed (homeModError mod loc))-                           else do r <- read_file file_path-                                   checkBuildDynamicToo r-                                   return r-                   err -> do-                       traceIf (text "...not found")-                       dflags <- getDynFlags-                       return (Failed (cannotFindInterface dflags-                                           (installedModuleName mod) err))-    where read_file file_path = do-              traceIf (text "readIFace" <+> text file_path)-              -- Figure out what is recorded in mi_module.  If this is-              -- a fully definite interface, it'll match exactly, but-              -- if it's indefinite, the inside will be uninstantiated!-              dflags <- getDynFlags-              let wanted_mod =-                    case splitModuleInsts wanted_mod_with_insts of-                        (_, Nothing) -> wanted_mod_with_insts-                        (_, Just indef_mod) ->-                          indefModuleToModule dflags-                            (generalizeIndefModule indef_mod)-              read_result <- readIface wanted_mod file_path-              case read_result of-                Failed err -> return (Failed (badIfaceFile file_path err))-                Succeeded iface -> return (Succeeded (iface, file_path))-                            -- Don't forget to fill in the package name...-          checkBuildDynamicToo (Succeeded (iface, filePath)) = do-              dflags <- getDynFlags-              -- Indefinite interfaces are ALWAYS non-dynamic, and-              -- that's OK.-              let is_definite_iface = moduleIsDefinite (mi_module iface)-              when is_definite_iface $-                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do-                  let ref = canGenerateDynamicToo dflags-                      dynFilePath = addBootSuffix_maybe hi_boot_file-                                  $ replaceExtension filePath (dynHiSuf dflags)-                  r <- read_file dynFilePath-                  case r of-                      Succeeded (dynIface, _)-                       | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->-                          return ()-                       | otherwise ->-                          do traceIf (text "Dynamic hash doesn't match")-                             liftIO $ writeIORef ref False-                      Failed err ->-                          do traceIf (text "Failed to load dynamic interface file:" $$ err)-                             liftIO $ writeIORef ref False-          checkBuildDynamicToo _ = return ()---- @readIface@ tries just the one file.--readIface :: Module -> FilePath-          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)-        -- Failed err    <=> file not found, or unreadable, or illegible-        -- Succeeded iface <=> successfully found and parsed--readIface wanted_mod file_path-  = do  { res <- tryMostM $-                 readBinIface CheckHiWay QuietBinIFaceReading file_path-        ; dflags <- getDynFlags-        ; case res of-            Right iface-                -- NB: This check is NOT just a sanity check, it is-                -- critical for correctness of recompilation checking-                -- (it lets us tell when -this-unit-id has changed.)-                | wanted_mod == actual_mod-                                -> return (Succeeded iface)-                | otherwise     -> return (Failed err)-                where-                  actual_mod = mi_module iface-                  err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod--            Left exn    -> return (Failed (text (showException exn)))-    }--{--*********************************************************-*                                                       *-        Wired-in interface for GHC.Prim-*                                                       *-*********************************************************--}--initExternalPackageState :: ExternalPackageState-initExternalPackageState-  = EPS {-      eps_is_boot          = emptyUFM,-      eps_PIT              = emptyPackageIfaceTable,-      eps_free_holes       = emptyInstalledModuleEnv,-      eps_PTE              = emptyTypeEnv,-      eps_inst_env         = emptyInstEnv,-      eps_fam_inst_env     = emptyFamInstEnv,-      eps_rule_base        = mkRuleBase builtinRules,-        -- Initialise the EPS rule pool with the built-in rules-      eps_mod_fam_inst_env-                           = emptyModuleEnv,-      eps_complete_matches = emptyUFM,-      eps_ann_env          = emptyAnnEnv,-      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0-                           , n_insts_in = 0, n_insts_out = 0-                           , n_rules_in = length builtinRules, n_rules_out = 0 }-    }--{--*********************************************************-*                                                       *-        Wired-in interface for GHC.Prim-*                                                       *-*********************************************************--}--ghcPrimIface :: ModIface-ghcPrimIface-  = empty_iface {-        mi_exports  = ghcPrimExports,-        mi_decls    = [],-        mi_fixities = fixities,-        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }-        }-  where-    empty_iface = emptyFullModIface gHC_PRIM--    -- The fixities listed here for @`seq`@ or @->@ should match-    -- those in primops.txt.pp (from which Haddock docs are generated).-    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)-             : (occName funTyConName, funTyFixity)  -- trac #10145-             : mapMaybe mkFixity allThePrimOps-    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op--{--*********************************************************-*                                                      *-\subsection{Statistics}-*                                                      *-*********************************************************--}--ifaceStats :: ExternalPackageState -> SDoc-ifaceStats eps-  = hcat [text "Renamer stats: ", msg]-  where-    stats = eps_stats eps-    msg = vcat-        [int (n_ifaces_in stats) <+> text "interfaces read",-         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",-                int (n_decls_in stats), text "read"],-         hsep [ int (n_insts_out stats), text "instance decls imported, out of",-                int (n_insts_in stats), text "read"],-         hsep [ int (n_rules_out stats), text "rule decls imported, out of",-                int (n_rules_in stats), text "read"]-        ]--{--************************************************************************-*                                                                      *-                Printing interfaces-*                                                                      *-************************************************************************--Note [Name qualification with --show-iface]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In order to disambiguate between identifiers from different modules, we qualify-all names that don't originate in the current module. In order to keep visual-noise as low as possible, we keep local names unqualified.--For some background on this choice see trac #15269.--}---- | Read binary interface, and print it out-showIface :: HscEnv -> FilePath -> IO ()-showIface hsc_env filename = do-   -- skip the hi way check; we don't want to worry about profiled vs.-   -- non-profiled interfaces, for example.-   iface <- initTcRnIf 's' hsc_env () () $-       readBinIface IgnoreHiWay TraceBinIFaceReading filename-   let dflags = hsc_dflags hsc_env-       -- See Note [Name qualification with --show-iface]-       qualifyImportedNames mod _-           | mod == mi_module iface = NameUnqual-           | otherwise              = NameNotInScope1-       print_unqual = QueryQualify qualifyImportedNames-                                   neverQualifyModules-                                   neverQualifyPackages-   putLogMsg dflags NoReason SevDump noSrcSpan-      (mkDumpStyle dflags print_unqual) (pprModIface iface)---- Show a ModIface but don't display details; suitable for ModIfaces stored in--- the EPT.-pprModIfaceSimple :: ModIface -> SDoc-pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))--pprModIface :: ModIface -> SDoc--- Show a ModIface-pprModIface iface@ModIface{ mi_final_exts = exts }- = vcat [ text "interface"-                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)-                <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)-                <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)-                <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)-                <+> integer hiVersion-        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))-        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts))-        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))-        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts))-        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts))-        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))-        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))-        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))-        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))-        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))-        , nest 2 (text "where")-        , text "exports:"-        , nest 2 (vcat (map pprExport (mi_exports iface)))-        , pprDeps (mi_deps iface)-        , vcat (map pprUsage (mi_usages iface))-        , vcat (map pprIfaceAnnotation (mi_anns iface))-        , pprFixities (mi_fixities iface)-        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]-        , vcat (map ppr (mi_insts iface))-        , vcat (map ppr (mi_fam_insts iface))-        , vcat (map ppr (mi_rules iface))-        , ppr (mi_warns iface)-        , pprTrustInfo (mi_trust iface)-        , pprTrustPkg (mi_trust_pkg iface)-        , vcat (map ppr (mi_complete_sigs iface))-        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))-        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))-        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))-        ]-  where-    pp_hsc_src HsBootFile = text "[boot]"-    pp_hsc_src HsigFile = text "[hsig]"-    pp_hsc_src HsSrcFile = Outputable.empty--{--When printing export lists, we print like this:-        Avail   f               f-        AvailTC C [C, x, y]     C(x,y)-        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C--}--pprExport :: IfaceExport -> SDoc-pprExport (Avail n)         = ppr n-pprExport (AvailTC _ [] []) = Outputable.empty-pprExport (AvailTC n ns0 fs)-  = case ns0 of-      (n':ns) | n==n' -> ppr n <> pp_export ns fs-      _               -> ppr n <> vbar <> pp_export ns0 fs-  where-    pp_export []    [] = Outputable.empty-    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))--pprUsage :: Usage -> SDoc-pprUsage usage@UsagePackageModule{}-  = pprUsageImport usage usg_mod-pprUsage usage@UsageHomeModule{}-  = pprUsageImport usage usg_mod_name $$-    nest 2 (-        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$-        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]-        )-pprUsage usage@UsageFile{}-  = hsep [text "addDependentFile",-          doubleQuotes (text (usg_file_path usage)),-          ppr (usg_file_hash usage)]-pprUsage usage@UsageMergedRequirement{}-  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]--pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc-pprUsageImport usage usg_mod'-  = hsep [text "import", safe, ppr (usg_mod' usage),-                       ppr (usg_mod_hash usage)]-    where-        safe | usg_safe usage = text "safe"-             | otherwise      = text " -/ "--pprDeps :: Dependencies -> SDoc-pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,-                dep_finsts = finsts })-  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),-          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),-          text "orphans:" <+> fsep (map ppr orphs),-          text "family instance modules:" <+> fsep (map ppr finsts)-        ]-  where-    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot-    ppr_pkg (pkg,trust_req)  = ppr pkg <>-                               (if trust_req then text "*" else Outputable.empty)-    ppr_boot True  = text "[boot]"-    ppr_boot False = Outputable.empty--pprFixities :: [(OccName, Fixity)] -> SDoc-pprFixities []    = Outputable.empty-pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes-                  where-                    pprFix (occ,fix) = ppr fix <+> ppr occ--pprTrustInfo :: IfaceTrustInfo -> SDoc-pprTrustInfo trust = text "trusted:" <+> ppr trust--pprTrustPkg :: Bool -> SDoc-pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg--instance Outputable Warnings where-    ppr = pprWarns--pprWarns :: Warnings -> SDoc-pprWarns NoWarnings         = Outputable.empty-pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt-pprWarns (WarnSome prs) = text "Warnings"-                        <+> vcat (map pprWarning prs)-    where pprWarning (name, txt) = ppr name <+> ppr txt--pprIfaceAnnotation :: IfaceAnnotation -> SDoc-pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })-  = ppr target <+> text "annotated by" <+> ppr serialized--{--*********************************************************-*                                                       *-\subsection{Errors}-*                                                       *-*********************************************************--}--badIfaceFile :: String -> SDoc -> SDoc-badIfaceFile file err-  = vcat [text "Bad interface file:" <+> text file,-          nest 4 err]--hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc-hiModuleNameMismatchWarn dflags requested_mod read_mod- | moduleUnitId requested_mod == moduleUnitId read_mod =-    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,-         text "but we were expecting module" <+> quotes (ppr requested_mod),-         sep [text "Probable cause: the source code which generated interface file",-             text "has an incompatible module name"-            ]-        ]- | otherwise =-  -- ToDo: This will fail to have enough qualification when the package IDs-  -- are the same-  withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $-    -- we want the Modules below to be qualified with package names,-    -- so reset the PrintUnqualified setting.-    hsep [ text "Something is amiss; requested module "-         , ppr requested_mod-         , text "differs from name found in the interface file"-         , ppr read_mod-         , parens (text "if these names look the same, try again with -dppr-debug")-         ]--homeModError :: InstalledModule -> ModLocation -> SDoc--- See Note [Home module load error]-homeModError mod location-  = text "attempting to use module " <> quotes (ppr mod)-    <> (case ml_hs_file location of-           Just file -> space <> parens (text file)-           Nothing   -> Outputable.empty)-    <+> text "which is not loaded"
− compiler/iface/LoadIface.hs-boot 
@@ -1,7 +0,0 @@-module LoadIface where-import Module (Module)-import TcRnMonad (IfM)-import HscTypes (ModIface)-import Outputable (SDoc)--loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
− compiler/iface/MkIface.hs 
@@ -1,2078 +0,0 @@-{--(c) The University of Glasgow 2006-2008-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998--}--{-# LANGUAGE CPP, NondecreasingIndentation #-}-{-# LANGUAGE MultiWayIf #-}---- | Module for constructing @ModIface@ values (interface files),--- writing them to disk and comparing two versions to see if--- recompilation is required.-module MkIface (-        mkPartialIface,-        mkFullIface,--        mkIfaceTc,--        writeIfaceFile, -- Write the interface file--        checkOldIface,  -- See if recompilation is required, by-                        -- comparing version information-        RecompileRequired(..), recompileRequired,-        mkIfaceExports,--        coAxiomToIfaceDecl,-        tyThingToIfaceDecl -- Converting things to their Iface equivalents- ) where--{--  ------------------------------------------------          Recompilation checking-  -------------------------------------------------A complete description of how recompilation checking works can be-found in the wiki commentary:-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance--Please read the above page for a top-down description of how this all-works.  Notes below cover specific issues related to the implementation.--Basic idea:--  * In the mi_usages information in an interface, we record the-    fingerprint of each free variable of the module--  * In mkIface, we compute the fingerprint of each exported thing A.f.-    For each external thing that A.f refers to, we include the fingerprint-    of the external reference when computing the fingerprint of A.f.  So-    if anything that A.f depends on changes, then A.f's fingerprint will-    change.-    Also record any dependent files added with-      * addDependentFile-      * #include-      * -optP-include--  * In checkOldIface we compare the mi_usages for the module with-    the actual fingerprint for all each thing recorded in mi_usages--}--#include "HsVersions.h"--import GhcPrelude--import IfaceSyn-import BinFingerprint-import LoadIface-import ToIface-import FlagChecker--import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )-import Id-import Annotations-import CoreSyn-import Class-import TyCon-import CoAxiom-import ConLike-import DataCon-import Type-import TcType-import InstEnv-import FamInstEnv-import TcRnMonad-import GHC.Hs-import HscTypes-import Finder-import DynFlags-import VarEnv-import Var-import Name-import Avail-import RdrName-import NameEnv-import NameSet-import Module-import BinIface-import ErrUtils-import Digraph-import SrcLoc-import Outputable-import BasicTypes       hiding ( SuccessFlag(..) )-import Unique-import Util             hiding ( eqListBy )-import FastString-import Maybes-import Binary-import Fingerprint-import Exception-import UniqSet-import Packages-import ExtractDocs--import Control.Monad-import Data.Function-import Data.List-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Ord-import Data.IORef-import System.Directory-import System.FilePath-import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),-                 pluginRecompile', plugins )----Qualified import so we can define a Semigroup instance--- but it doesn't clash with Outputable.<>-import qualified Data.Semigroup--{--************************************************************************-*                                                                      *-\subsection{Completing an interface}-*                                                                      *-************************************************************************--}--mkPartialIface :: HscEnv-               -> ModDetails-               -> ModGuts-               -> PartialModIface-mkPartialIface hsc_env mod_details-  ModGuts{ mg_module       = this_mod-         , mg_hsc_src      = hsc_src-         , mg_usages       = usages-         , mg_used_th      = used_th-         , mg_deps         = deps-         , mg_rdr_env      = rdr_env-         , mg_fix_env      = fix_env-         , mg_warns        = warns-         , mg_hpc_info     = hpc_info-         , mg_safe_haskell = safe_mode-         , mg_trust_pkg    = self_trust-         , mg_doc_hdr      = doc_hdr-         , mg_decl_docs    = decl_docs-         , mg_arg_docs     = arg_docs-         }-  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust-             safe_mode usages doc_hdr decl_docs arg_docs mod_details---- | Fully instantiate a interface--- Adds fingerprints and potentially code generator produced information.-mkFullIface :: HscEnv -> PartialModIface -> IO ModIface-mkFullIface hsc_env partial_iface = do-    full_iface <--      {-# SCC "addFingerprints" #-}-      addFingerprints hsc_env partial_iface--    -- Debug printing-    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)--    return full_iface---- | Make an interface from the results of typechecking only.  Useful--- for non-optimising compilation, or where we aren't generating any--- object code at all ('HscNothing').-mkIfaceTc :: HscEnv-          -> SafeHaskellMode    -- The safe haskell mode-          -> ModDetails         -- gotten from mkBootModDetails, probably-          -> TcGblEnv           -- Usages, deprecations, etc-          -> IO ModIface-mkIfaceTc hsc_env safe_mode mod_details-  tc_result@TcGblEnv{ tcg_mod = this_mod,-                      tcg_src = hsc_src,-                      tcg_imports = imports,-                      tcg_rdr_env = rdr_env,-                      tcg_fix_env = fix_env,-                      tcg_merged = merged,-                      tcg_warns = warns,-                      tcg_hpc = other_hpc_info,-                      tcg_th_splice_used = tc_splice_used,-                      tcg_dependent_files = dependent_files-                    }-  = do-          let used_names = mkUsedNames tc_result-          let pluginModules =-                map lpModule (cachedPlugins (hsc_dflags hsc_env))-          deps <- mkDependencies-                    (thisInstalledUnitId (hsc_dflags hsc_env))-                    (map mi_module pluginModules) tc_result-          let hpc_info = emptyHpcInfo other_hpc_info-          used_th <- readIORef tc_splice_used-          dep_files <- (readIORef dependent_files)-          -- Do NOT use semantic module here; this_mod in mkUsageInfo-          -- is used solely to decide if we should record a dependency-          -- or not.  When we instantiate a signature, the semantic-          -- module is something we want to record dependencies for,-          -- but if you pass that in here, we'll decide it's the local-          -- module and does not need to be recorded as a dependency.-          -- See Note [Identity versus semantic module]-          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names-                      dep_files merged pluginModules--          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result--          let partial_iface = mkIface_ hsc_env-                   this_mod hsc_src-                   used_th deps rdr_env-                   fix_env warns hpc_info-                   (imp_trust_own_pkg imports) safe_mode usages-                   doc_hdr' doc_map arg_map-                   mod_details--          mkFullIface hsc_env partial_iface--mkIface_ :: HscEnv -> Module -> HscSource-         -> Bool -> Dependencies -> GlobalRdrEnv-         -> NameEnv FixItem -> Warnings -> HpcInfo-         -> Bool-         -> SafeHaskellMode-         -> [Usage]-         -> Maybe HsDocString-         -> DeclDocMap-         -> ArgDocMap-         -> ModDetails-         -> PartialModIface-mkIface_ hsc_env-         this_mod hsc_src used_th deps rdr_env fix_env src_warns-         hpc_info pkg_trust_req safe_mode usages-         doc_hdr decl_docs arg_docs-         ModDetails{  md_insts     = insts,-                      md_fam_insts = fam_insts,-                      md_rules     = rules,-                      md_anns      = anns,-                      md_types     = type_env,-                      md_exports   = exports,-                      md_complete_sigs = complete_sigs }--- NB:  notice that mkIface does not look at the bindings---      only at the TypeEnv.  The previous Tidy phase has---      put exactly the info into the TypeEnv that we want---      to expose in the interface--  = do-    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)-        entities = typeEnvElts type_env-        decls  = [ tyThingToIfaceDecl entity-                 | entity <- entities,-                   let name = getName entity,-                   not (isImplicitTyThing entity),-                      -- No implicit Ids and class tycons in the interface file-                   not (isWiredInName name),-                      -- Nor wired-in things; the compiler knows about them anyhow-                   nameIsLocalOrFrom semantic_mod name  ]-                      -- Sigh: see Note [Root-main Id] in TcRnDriver-                      -- NB: ABSOLUTELY need to check against semantic_mod,-                      -- because all of the names in an hsig p[H=<H>]:H-                      -- are going to be for <H>, not the former id!-                      -- 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-          -- deterministic, so we sort by OccName to canonicalize it.-          -- See Note [Deterministic UniqFM] in UniqDFM for more details.-        warns       = src_warns-        iface_rules = map coreRuleToIfaceRule rules-        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts-        iface_fam_insts = map famInstToIfaceFamInst fam_insts-        trust_info  = setSafeMode safe_mode-        annotations = map mkIfaceAnnotation anns-        icomplete_sigs = map mkIfaceCompleteSig complete_sigs--    ModIface {-          mi_module      = this_mod,-          -- Need to record this because it depends on the -instantiated-with flag-          -- which could change-          mi_sig_of      = if semantic_mod == this_mod-                            then Nothing-                            else Just semantic_mod,-          mi_hsc_src     = hsc_src,-          mi_deps        = deps,-          mi_usages      = usages,-          mi_exports     = mkIfaceExports exports,--          -- Sort these lexicographically, so that-          -- the result is stable across compilations-          mi_insts       = sortBy cmp_inst     iface_insts,-          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,-          mi_rules       = sortBy cmp_rule     iface_rules,--          mi_fixities    = fixities,-          mi_warns       = warns,-          mi_anns        = annotations,-          mi_globals     = maybeGlobalRdrEnv rdr_env,-          mi_used_th     = used_th,-          mi_decls       = decls,-          mi_hpc         = isHpcUsed hpc_info,-          mi_trust       = trust_info,-          mi_trust_pkg   = pkg_trust_req,-          mi_complete_sigs = icomplete_sigs,-          mi_doc_hdr     = doc_hdr,-          mi_decl_docs   = decl_docs,-          mi_arg_docs    = arg_docs,-          mi_final_exts  = () }-  where-     cmp_rule     = comparing ifRuleName-     -- Compare these lexicographically by OccName, *not* by unique,-     -- because the latter is not stable across compilations:-     cmp_inst     = comparing (nameOccName . ifDFun)-     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)--     dflags = hsc_dflags hsc_env--     -- We only fill in mi_globals if the module was compiled to byte-     -- code.  Otherwise, the compiler may not have retained all the-     -- top-level bindings and they won't be in the TypeEnv (see-     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used-     -- by GHCi to decide whether the module has its full top-level-     -- scope available. (#5534)-     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv-     maybeGlobalRdrEnv rdr_env-         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env-         | otherwise                                   = Nothing--     ifFamInstTcName = ifFamInstFam--------------------------------writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()-writeIfaceFile dflags hi_file_path new_iface-    = do createDirectoryIfMissing True (takeDirectory hi_file_path)-         writeBinIface dflags hi_file_path new_iface----- -------------------------------------------------------------------------------- Look up parents and versions of Names---- This is like a global version of the mi_hash_fn field in each ModIface.--- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get--- the parent and version info.--mkHashFun-        :: HscEnv                       -- needed to look up versions-        -> ExternalPackageState         -- ditto-        -> (Name -> IO Fingerprint)-mkHashFun hsc_env eps name-  | isHoleModule orig_mod-  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))-  | otherwise-  = lookup orig_mod-  where-      dflags = hsc_dflags hsc_env-      hpt = hsc_HPT hsc_env-      pit = eps_PIT eps-      occ = nameOccName name-      orig_mod = nameModule name-      lookup mod = do-        MASSERT2( isExternalName name, ppr name )-        iface <- case lookupIfaceByModule hpt pit mod of-                  Just iface -> return iface-                  Nothing -> do-                      -- This can occur when we're writing out ifaces for-                      -- requirements; we didn't do any /real/ typechecking-                      -- so there's no guarantee everything is loaded.-                      -- Kind of a heinous hack.-                      iface <- initIfaceLoad hsc_env . withException-                            $ loadInterface (text "lookupVers2") mod ImportBySystem-                      return iface-        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`-                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))---- ------------------------------------------------------------------------------ Compute fingerprints for the interface--{--Note [Fingerprinting IfaceDecls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The general idea here is that we first examine the 'IfaceDecl's and determine-the recursive groups of them. We then walk these groups in dependency order,-serializing each contained 'IfaceDecl' to a "Binary" buffer which we then-hash using MD5 to produce a fingerprint for the group.--However, the serialization that we use is a bit funny: we override the @putName@-operation with our own which serializes the hash of a 'Name' instead of the-'Name' itself. This ensures that the fingerprint of a decl changes if anything-in its transitive closure changes. This trick is why we must be careful about-traversing in dependency order: we need to ensure that we have hashes for-everything referenced by the decl which we are fingerprinting.--Moreover, we need to be careful to distinguish between serialization of binding-Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls-field of a IfaceClsInst): only in the non-binding case should we include the-fingerprint; in the binding case we shouldn't since it is merely the name of the-thing that we are currently fingerprinting.--}---- | Add fingerprints for top-level declarations to a 'ModIface'.------ See Note [Fingerprinting IfaceDecls]-addFingerprints-        :: HscEnv-        -> PartialModIface-        -> IO ModIface-addFingerprints hsc_env iface0- = do-   eps <- hscEPS hsc_env-   let-       decls = mi_decls iface0-       warn_fn = mkIfaceWarnCache (mi_warns iface0)-       fix_fn = mkIfaceFixCache (mi_fixities iface0)--        -- The ABI of a declaration represents everything that is made-        -- visible about the declaration that a client can depend on.-        -- see IfaceDeclABI below.-       declABI :: IfaceDecl -> IfaceDeclABI-       -- TODO: I'm not sure if this should be semantic_mod or this_mod.-       -- See also Note [Identity versus semantic module]-       declABI decl = (this_mod, decl, extras)-        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts-                                  non_orph_fis top_lvl_name_env decl--       -- This is used for looking up the Name of a default method-       -- from its OccName. See Note [default method Name]-       top_lvl_name_env =-         mkOccEnv [ (nameOccName nm, nm)-                  | IfaceId { ifName = nm } <- decls ]--       -- Dependency edges between declarations in the current module.-       -- This is computed by finding the free external names of each-       -- declaration, including IfaceDeclExtras (things that a-       -- declaration implicitly depends on).-       edges :: [ Node Unique IfaceDeclABI ]-       edges = [ DigraphNode abi (getUnique (getOccName decl)) out-               | decl <- decls-               , let abi = declABI decl-               , let out = localOccs $ freeNamesDeclABI abi-               ]--       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n-       localOccs =-         map (getUnique . getParent . getOccName)-                        -- NB: names always use semantic module, so-                        -- filtering must be on the semantic module!-                        -- See Note [Identity versus semantic module]-                        . filter ((== semantic_mod) . name_module)-                        . nonDetEltsUniqSet-                   -- It's OK to use nonDetEltsUFM as localOccs is only-                   -- used to construct the edges and-                   -- stronglyConnCompFromEdgedVertices is deterministic-                   -- even with non-deterministic order of edges as-                   -- explained in Note [Deterministic SCC] in Digraph.-          where getParent :: OccName -> OccName-                getParent occ = lookupOccEnv parent_map occ `orElse` occ--        -- maps OccNames to their parents in the current module.-        -- e.g. a reference to a constructor must be turned into a reference-        -- to the TyCon for the purposes of calculating dependencies.-       parent_map :: OccEnv OccName-       parent_map = foldl' extend emptyOccEnv decls-          where extend env d =-                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]-                  where n = getOccName d--        -- Strongly-connected groups of declarations, in dependency order-       groups :: [SCC IfaceDeclABI]-       groups = stronglyConnCompFromEdgedVerticesUniq edges--       global_hash_fn = mkHashFun hsc_env eps--        -- How to output Names when generating the data to fingerprint.-        -- Here we want to output the fingerprint for each top-level-        -- Name, whether it comes from the current module or another-        -- module.  In this way, the fingerprint for a declaration will-        -- change if the fingerprint for anything it refers to (transitively)-        -- changes.-       mk_put_name :: OccEnv (OccName,Fingerprint)-                   -> BinHandle -> Name -> IO  ()-       mk_put_name local_env bh name-          | isWiredInName name  =  putNameLiterally bh name-           -- wired-in names don't have fingerprints-          | otherwise-          = ASSERT2( isExternalName name, ppr name )-            let hash | nameModule name /= semantic_mod =  global_hash_fn name-                     -- Get it from the REAL interface!!-                     -- This will trigger when we compile an hsig file-                     -- and we know a backing impl for it.-                     -- See Note [Identity versus semantic module]-                     | semantic_mod /= this_mod-                     , not (isHoleModule semantic_mod) = global_hash_fn name-                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)-                           `orElse` pprPanic "urk! lookup local fingerprint"-                                       (ppr name $$ ppr local_env)))-                -- This panic indicates that we got the dependency-                -- analysis wrong, because we needed a fingerprint for-                -- an entity that wasn't in the environment.  To debug-                -- it, turn the panic into a trace, uncomment the-                -- pprTraces below, run the compile again, and inspect-                -- the output and the generated .hi file with-                -- --show-iface.-            in hash >>= put_ bh--        -- take a strongly-connected group of declarations and compute-        -- its fingerprint.--       fingerprint_group :: (OccEnv (OccName,Fingerprint),-                             [(Fingerprint,IfaceDecl)])-                         -> SCC IfaceDeclABI-                         -> IO (OccEnv (OccName,Fingerprint),-                                [(Fingerprint,IfaceDecl)])--       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)-          = do let hash_fn = mk_put_name local_env-                   decl = abiDecl abi-               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do-               hash <- computeFingerprint hash_fn abi-               env' <- extend_hash_env local_env (hash,decl)-               return (env', (hash,decl) : decls_w_hashes)--       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)-          = do let decls = map abiDecl abis-               local_env1 <- foldM extend_hash_env local_env-                                   (zip (repeat fingerprint0) decls)-               let hash_fn = mk_put_name local_env1-               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do-               let stable_abis = sortBy cmp_abiNames abis-                -- put the cycle in a canonical order-               hash <- computeFingerprint hash_fn stable_abis-               let pairs = zip (repeat hash) decls-               local_env2 <- foldM extend_hash_env local_env pairs-               return (local_env2, pairs ++ decls_w_hashes)--       -- we have fingerprinted the whole declaration, but we now need-       -- to assign fingerprints to all the OccNames that it binds, to-       -- use when referencing those OccNames in later declarations.-       ---       extend_hash_env :: OccEnv (OccName,Fingerprint)-                       -> (Fingerprint,IfaceDecl)-                       -> IO (OccEnv (OccName,Fingerprint))-       extend_hash_env env0 (hash,d) = do-          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0-                 (ifaceDeclFingerprints hash d))--   ---   (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:-   let sorted_deps = sortDependencies (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-   -- that changes in orphans get propagated all the way up the-   -- dependency tree.-   ---   -- Note [A bad dep_orphs optimization]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- In a previous version of this code, we filtered out orphan modules which-   -- were not from the home package, justifying it by saying that "we'd-   -- pick up the ABI hashes of the external module instead".  This is wrong.-   -- Suppose that we have:-   ---   --       module External where-   --           instance Show (a -> b)-   ---   --       module Home1 where-   --           import External-   ---   --       module Home2 where-   --           import Home1-   ---   -- The export hash of Home1 needs to reflect the orphan instances of-   -- External. It's true that Home1 will get rebuilt if the orphans-   -- of External, but we also need to make sure Home2 gets rebuilt-   -- as well.  See #12733 for more details.-   let orph_mods-        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]-        $ dep_orphs sorted_deps-   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods--   -- Note [Do not update EPS with your own hi-boot]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   -- (See also #10182).  When your hs-boot file includes an orphan-   -- instance declaration, you may find that the dep_orphs of a module you-   -- import contains reference to yourself.  DO NOT actually load this module-   -- or add it to the orphan hashes: you're going to provide the orphan-   -- instances yourself, no need to consult hs-boot; if you do load the-   -- interface into EPS, you will see a duplicate orphan instance.--   orphan_hash <- computeFingerprint (mk_put_name local_env)-                                     (map ifDFun orph_insts, orph_rules, orph_fis)--   -- the export list hash doesn't depend on the fingerprints of-   -- the Names it mentions, only the Names themselves, hence putNameLiterally.-   export_hash <- computeFingerprint putNameLiterally-                      (mi_exports iface0,-                       orphan_hash,-                       dep_orphan_hashes,-                       dep_pkgs (mi_deps iface0),-                       -- See Note [Export hash depends on non-orphan family instances]-                       dep_finsts (mi_deps iface0),-                        -- dep_pkgs: see "Package Version Changes" on-                        -- wiki/commentary/compiler/recompilation-avoidance-                       mi_trust iface0)-                        -- Make sure change of Safe Haskell mode causes recomp.--   -- Note [Export hash depends on non-orphan family instances]-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   ---   -- Suppose we have:-   ---   --   module A where-   --       type instance F Int = Bool-   ---   --   module B where-   --       import A-   ---   --   module C where-   --       import B-   ---   -- The family instance consistency check for C depends on the dep_finsts of-   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need-   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of-   -- the exports of B, because C always considers them when checking-   -- consistency.-   ---   -- A full discussion is in #12723.-   ---   -- We do NOT need to hash dep_orphs, because this is implied by-   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,-   -- because there is no eager consistency check as there is with type families-   -- (also we didn't store it anywhere!)-   ----   -- put the declarations in a canonical order, sorted by OccName-   let sorted_decls = Map.elems $ Map.fromList $-                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]--   -- the flag hash depends on:-   --   - (some of) dflags-   -- it returns two hashes, one that shouldn't change-   -- the abi hash and one that should-   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally--   opt_hash <- fingerprintOptFlags dflags putNameLiterally--   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally--   plugin_hash <- fingerprintPlugins hsc_env--   -- the ABI hash depends on:-   --   - decls-   --   - export list-   --   - orphans-   --   - deprecations-   --   - flag abi hash-   mod_hash <- computeFingerprint putNameLiterally-                      (map fst sorted_decls,-                       export_hash,  -- includes orphan_hash-                       mi_warns iface0)--   -- The interface hash depends on:-   --   - the ABI hash, plus-   --   - the module level annotations,-   --   - usages-   --   - deps (home and external packages, dependent files)-   --   - hpc-   iface_hash <- computeFingerprint putNameLiterally-                      (mod_hash,-                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache-                       mi_usages iface0,-                       sorted_deps,-                       mi_hpc iface0)--   let-    final_iface_exts = ModIfaceBackend-      { mi_iface_hash  = iface_hash-      , mi_mod_hash    = mod_hash-      , mi_flag_hash   = flag_hash-      , mi_opt_hash    = opt_hash-      , mi_hpc_hash    = hpc_hash-      , mi_plugin_hash = plugin_hash-      , mi_orphan      = not (   all ifRuleAuto orph_rules-                                   -- See Note [Orphans and auto-generated rules]-                              && null orph_insts-                              && null orph_fis)-      , mi_finsts      = not (null (mi_fam_insts iface0))-      , mi_exp_hash    = export_hash-      , mi_orphan_hash = orphan_hash-      , mi_warn_fn     = warn_fn-      , mi_fix_fn      = fix_fn-      , mi_hash_fn     = lookupOccEnv local_env-      }-    final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }-   ---   return final_iface--  where-    this_mod = mi_module iface0-    semantic_mod = mi_semantic_module iface0-    dflags = hsc_dflags hsc_env-    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)-    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)-    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)-    ann_fn = mkIfaceAnnCache (mi_anns iface0)---- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules--- (in particular, the orphan modules which are transitively imported by the--- current module).------ Q: Why do we need the hash at all, doesn't the list of transitively--- imported orphan modules suffice?------ A: If one of our transitive imports adds a new orphan instance, our--- export hash must change so that modules which import us rebuild.  If we just--- hashed the [Module], the hash would not change even when a new instance was--- added to a module that already had an orphan instance.------ Q: Why don't we just hash the orphan hashes of our direct dependencies?--- Why the full transitive closure?------ A: Suppose we have these modules:------      module A where---          instance Show (a -> b) where---      module B where---          import A -- **---      module C where---          import A---          import B------ Whether or not we add or remove the import to A in B affects the--- orphan hash of B.  But it shouldn't really affect the orphan hash--- of C.  If we hashed only direct dependencies, there would be no--- way to tell that the net effect was a wash, and we'd be forced--- to recompile C and everything else.-getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]-getOrphanHashes hsc_env mods = do-  eps <- hscEPS hsc_env-  let-    hpt        = hsc_HPT hsc_env-    pit        = eps_PIT eps-    get_orph_hash mod =-          case lookupIfaceByModule hpt pit mod of-            Just iface -> return (mi_orphan_hash (mi_final_exts iface))-            Nothing    -> do -- similar to 'mkHashFun'-                iface <- initIfaceLoad hsc_env . withException-                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem-                return (mi_orphan_hash (mi_final_exts iface))--  ---  mapM get_orph_hash mods---sortDependencies :: Dependencies -> Dependencies-sortDependencies d- = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),-          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),-          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),-          dep_finsts = sortBy stableModuleCmp (dep_finsts d),-          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }---- | Creates cached lookup for the 'mi_anns' field of ModIface--- Hackily, we use "module" as the OccName for any module-level annotations-mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]-mkIfaceAnnCache anns-  = \n -> lookupOccEnv env n `orElse` []-  where-    pair (IfaceAnnotation target value) =-      (case target of-          NamedTarget occn -> occn-          ModuleTarget _   -> mkVarOcc "module"-      , [value])-    -- flipping (++), so the first argument is always short-    env = mkOccEnv_C (flip (++)) (map pair anns)--{--************************************************************************-*                                                                      *-          The ABI of an IfaceDecl-*                                                                      *-************************************************************************--Note [The ABI of an IfaceDecl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The ABI of a declaration consists of:--   (a) the full name of the identifier (inc. module and package,-       because these are used to construct the symbol name by which-       the identifier is known externally).--   (b) the declaration itself, as exposed to clients.  That is, the-       definition of an Id is included in the fingerprint only if-       it is made available as an unfolding in the interface.--   (c) the fixity of the identifier (if it exists)-   (d) for Ids: rules-   (e) for classes: instances, fixity & rules for methods-   (f) for datatypes: instances, fixity & rules for constrs--Items (c)-(f) are not stored in the IfaceDecl, but instead appear-elsewhere in the interface file.  But they are *fingerprinted* with-the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,-and fingerprinting that as part of the declaration.--}--type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)--data IfaceDeclExtras-  = IfaceIdExtras IfaceIdExtras--  | IfaceDataExtras-       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)-       [IfaceInstABI]           -- Local class and family instances of this tycon-                                -- See Note [Orphans] in InstEnv-       [AnnPayload]             -- Annotations of the type itself-       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations--  | IfaceClassExtras-       (Maybe Fixity)           -- Fixity of the class itself (if it exists)-       [IfaceInstABI]           -- Local instances of this class *or*-                                --   of its associated data types-                                -- See Note [Orphans] in InstEnv-       [AnnPayload]             -- Annotations of the type itself-       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations-       [IfExtName]              -- Default methods. If a module-                                -- mentions a class, then it can-                                -- instantiate the class and thereby-                                -- use the default methods, so we must-                                -- include these in the fingerprint of-                                -- a class.--  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]--  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]--  | IfaceOtherDeclExtras--data IfaceIdExtras-  = IdExtras-       (Maybe Fixity)           -- Fixity of the Id (if it exists)-       [IfaceRule]              -- Rules for the Id-       [AnnPayload]             -- Annotations for the Id---- When hashing a class or family instance, we hash only the--- DFunId or CoAxiom, because that depends on all the--- information about the instance.----type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance--abiDecl :: IfaceDeclABI -> IfaceDecl-abiDecl (_, decl, _) = decl--cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering-cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`-                         getOccName (abiDecl abi2)--freeNamesDeclABI :: IfaceDeclABI -> NameSet-freeNamesDeclABI (_mod, decl, extras) =-  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras--freeNamesDeclExtras :: IfaceDeclExtras -> NameSet-freeNamesDeclExtras (IfaceIdExtras id_extras)-  = freeNamesIdExtras id_extras-freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)-  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)-freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)-  = unionNameSets $-      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs-freeNamesDeclExtras (IfaceSynonymExtras _ _)-  = emptyNameSet-freeNamesDeclExtras (IfaceFamilyExtras _ insts _)-  = mkNameSet insts-freeNamesDeclExtras IfaceOtherDeclExtras-  = emptyNameSet--freeNamesIdExtras :: IfaceIdExtras -> NameSet-freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)--instance Outputable IfaceDeclExtras where-  ppr IfaceOtherDeclExtras       = Outputable.empty-  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras-  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]-  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]-  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,-                                                ppr_id_extras_s stuff]-  ppr (IfaceClassExtras fix insts anns stuff defms) =-    vcat [ppr fix, ppr_insts insts, ppr anns,-          ppr_id_extras_s stuff, ppr defms]--ppr_insts :: [IfaceInstABI] -> SDoc-ppr_insts _ = text "<insts>"--ppr_id_extras_s :: [IfaceIdExtras] -> SDoc-ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)--ppr_id_extras :: IfaceIdExtras -> SDoc-ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)---- This instance is used only to compute fingerprints-instance Binary IfaceDeclExtras where-  get _bh = panic "no get for IfaceDeclExtras"-  put_ bh (IfaceIdExtras extras) = do-   putByte bh 1; put_ bh extras-  put_ bh (IfaceDataExtras fix insts anns cons) = do-   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons-  put_ bh (IfaceClassExtras fix insts anns methods defms) = do-   putByte bh 3-   put_ bh fix-   put_ bh insts-   put_ bh anns-   put_ bh methods-   put_ bh defms-  put_ bh (IfaceSynonymExtras fix anns) = do-   putByte bh 4; put_ bh fix; put_ bh anns-  put_ bh (IfaceFamilyExtras fix finsts anns) = do-   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns-  put_ bh IfaceOtherDeclExtras = putByte bh 6--instance Binary IfaceIdExtras where-  get _bh = panic "no get for IfaceIdExtras"-  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }--declExtras :: (OccName -> Maybe Fixity)-           -> (OccName -> [AnnPayload])-           -> OccEnv [IfaceRule]-           -> OccEnv [IfaceClsInst]-           -> OccEnv [IfaceFamInst]-           -> OccEnv IfExtName          -- lookup default method names-           -> IfaceDecl-           -> IfaceDeclExtras--declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl-  = case decl of-      IfaceId{} -> IfaceIdExtras (id_extras n)-      IfaceData{ifCons=cons} ->-                     IfaceDataExtras (fix_fn n)-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++-                         map ifDFun         (lookupOccEnvL inst_env n))-                        (ann_fn n)-                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))-      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->-                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms-          where-            insts = (map ifDFun $ (concatMap at_extras ats)-                                    ++ lookupOccEnvL inst_env n)-                           -- Include instances of the associated types-                           -- as well as instances of the class (#5147)-            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]-            -- Names of all the default methods (see Note [default method Name])-            defms = [ dmName-                    | IfaceClassOp bndr _ (Just _) <- sigs-                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)-                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]-      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)-                                           (ann_fn n)-      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))-                        (ann_fn n)-      _other -> IfaceOtherDeclExtras-  where-        n = getOccName decl-        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)-        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)---{- Note [default method Name] (see also #15970)--The Names for the default methods aren't available in the IfaceSyn.--* We originally start with a DefMethInfo from the class, contain a-  Name for the default method--* We turn that into IfaceSyn as a DefMethSpec which lacks a Name-  entirely. Why? Because the Name can be derived from the method name-  (in TcIface), so doesn't need to be serialised into the interface-  file.--But now we have to get the Name back, because the class declaration's-fingerprint needs to depend on it (this was the bug in #15970).  This-is done in a slightly convoluted way:--* Then, in addFingerprints we build a map that maps OccNames to Names--* We pass that map to declExtras which laboriously looks up in the map-  (using the derived occurrence name) to recover the Name we have just-  thrown away.--}--lookupOccEnvL :: OccEnv [v] -> OccName -> [v]-lookupOccEnvL env k = lookupOccEnv env k `orElse` []--{---- for testing: use the md5sum command to generate fingerprints and--- compare the results against our built-in version.-  fp' <- oldMD5 dflags bh-  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')-               else return fp--oldMD5 dflags bh = do-  tmp <- newTempName dflags CurrentModule "bin"-  writeBinMem bh tmp-  tmp2 <- newTempName dflags CurrentModule "md5"-  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2-  r <- system cmd-  case r of-    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)-    ExitSuccess -> do-        hash_str <- readFile tmp2-        return $! readHexFingerprint hash_str--}--------------------------- mkOrphMap partitions instance decls or rules into---      (a) an OccEnv for ones that are not orphans,---          mapping the local OccName to a list of its decls---      (b) a list of orphan decls-mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl-          -> [decl]             -- Sorted into canonical order-          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;-                                --      each sublist in canonical order-              [decl])           -- Orphan decls; in canonical order-mkOrphMap get_key decls-  = foldl' go (emptyOccEnv, []) decls-  where-    go (non_orphs, orphs) d-        | NotOrphan occ <- get_key d-        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)-        | otherwise = (non_orphs, d:orphs)--{--************************************************************************-*                                                                      *-       COMPLETE Pragmas-*                                                                      *-************************************************************************--}--mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch-mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc---{--************************************************************************-*                                                                      *-       Keeping track of what we've slurped, and fingerprints-*                                                                      *-************************************************************************--}---mkIfaceAnnotation :: Annotation -> IfaceAnnotation-mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })-  = IfaceAnnotation {-        ifAnnotatedTarget = fmap nameOccName target,-        ifAnnotatedValue = payload-    }--mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical-mkIfaceExports exports-  = sortBy stableAvailCmp (map sort_subs exports)-  where-    sort_subs :: AvailInfo -> AvailInfo-    sort_subs (Avail n) = Avail n-    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)-    sort_subs (AvailTC n (m:ms) fs)-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)-       -- Maintain the AvailTC Invariant--    sort_flds = sortBy (stableNameCmp `on` flSelector)--{--Note [Original module]-~~~~~~~~~~~~~~~~~~~~~-Consider this:-        module X where { data family T }-        module Y( T(..) ) where { import X; data instance T Int = MkT Int }-The exported Avail from Y will look like-        X.T{X.T, Y.MkT}-That is, in Y,-  - only MkT is brought into scope by the data instance;-  - but the parent (used for grouping and naming in T(..) exports) is X.T-  - and in this case we export X.T too--In the result of MkIfaceExports, the names are grouped by defining module,-so we may need to split up a single Avail into multiple ones.--Note [Internal used_names]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Most of the used_names are External Names, but we can have Internal-Names too: see Note [Binders in Template Haskell] in Convert, and-#5362 for an example.  Such Names are always-  - Such Names are always for locally-defined things, for which we-    don't gather usage info, so we can just ignore them in ent_map-  - They are always System Names, hence the assert, just as a double check.---************************************************************************-*                                                                      *-        Load the old interface file for this module (unless-        we have it already), and check whether it is up to date-*                                                                      *-************************************************************************--}--data RecompileRequired-  = UpToDate-       -- ^ everything is up to date, recompilation is not required-  | MustCompile-       -- ^ The .hs file has been touched, or the .o/.hi file does not exist-  | RecompBecause String-       -- ^ 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--instance Semigroup RecompileRequired where-  UpToDate <> r = r-  mc <> _       = mc--instance Monoid RecompileRequired where-  mempty = UpToDate--recompileRequired :: RecompileRequired -> Bool-recompileRequired UpToDate = False-recompileRequired _ = True------ | 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--- first element is a bool saying if we should recompile the object file--- and the second is maybe the interface file, where Nothing means to--- rebuild the interface file and not use the existing one.-checkOldIface-  :: HscEnv-  -> ModSummary-  -> SourceModified-  -> Maybe ModIface         -- Old interface from compilation manager, if any-  -> IO (RecompileRequired, Maybe ModIface)--checkOldIface hsc_env mod_summary source_modified maybe_iface-  = do  let dflags = hsc_dflags hsc_env-        showPass dflags $-            "Checking old interface for " ++-              (showPpr dflags $ ms_mod mod_summary) ++-              " (use -ddump-hi-diffs for more details)"-        initIfaceCheck (text "checkOldIface") hsc_env $-            check_old_iface hsc_env mod_summary source_modified maybe_iface--check_old_iface-  :: HscEnv-  -> ModSummary-  -> SourceModified-  -> Maybe ModIface-  -> IfG (RecompileRequired, Maybe ModIface)--check_old_iface hsc_env mod_summary src_modified maybe_iface-  = let dflags = hsc_dflags hsc_env-        getIface =-            case maybe_iface of-                Just _  -> do-                    traceIf (text "We already have the old interface for" <+>-                      ppr (ms_mod mod_summary))-                    return maybe_iface-                Nothing -> loadIface--        loadIface = do-             let iface_path = msHiFilePath mod_summary-             read_result <- readIface (ms_mod mod_summary) iface_path-             case read_result of-                 Failed err -> do-                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)-                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)-                     return Nothing-                 Succeeded iface -> do-                     traceIf (text "Read the interface file" <+> text iface_path)-                     return $ Just iface--        src_changed-            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True-            | SourceModified <- src_modified = True-            | otherwise = False-    in do-        when src_changed $-            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")--        case src_changed of-            -- If the source has changed and we're in interactive mode,-            -- avoid reading an interface; just return the one we might-            -- have been supplied with.-            True | not (isObjectTarget $ hscTarget dflags) ->-                return (MustCompile, maybe_iface)--            -- Try and read the old interface for the current module-            -- from the .hi file left from the last time we compiled it-            True -> do-                maybe_iface' <- getIface-                return (MustCompile, maybe_iface')--            False -> do-                maybe_iface' <- getIface-                case maybe_iface' of-                    -- We can't retrieve the iface-                    Nothing    -> return (MustCompile, Nothing)--                    -- We have got the old iface; check its versions-                    -- even in the SourceUnmodifiedAndStable case we-                    -- should check versions because some packages-                    -- might have changed or gone away.-                    Just iface -> checkVersions hsc_env mod_summary iface---- | Check if a module is still the same 'version'.------ This function is called in the recompilation checker after we have--- determined that the module M being checked hasn't had any changes--- to its source file since we last compiled M. So at this point in general--- two things may have changed that mean we should recompile M:---   * The interface export by a dependency of M has changed.---   * The compiler flags specified this time for M have changed---     in a manner that is significant for recompilation.--- We return not just if we should recompile the object file but also--- if we should rebuild the interface file.-checkVersions :: HscEnv-              -> ModSummary-              -> ModIface       -- Old interface-              -> IfG (RecompileRequired, Maybe ModIface)-checkVersions hsc_env mod_summary iface-  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>-                        ppr (mi_module iface) <> colon)--       -- readIface will have verified that the InstalledUnitId matches,-       -- but we ALSO must make sure the instantiation matches up.  See-       -- test case bkpcabal04!-       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)-            then return (RecompBecause "-this-unit-id changed", Nothing) else do {-       ; recomp <- checkFlagHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkOptimHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHpcHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkMergedSignatures mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHsig mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- checkHie 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 {-       ; recomp <- checkPlugins hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {---       -- Source code unchanged and no errors yet... carry on-       ---       -- First put the dependent-module info, read from the old-       -- interface, into the envt, so that when we look for-       -- interfaces we look for the right one (.hi or .hi-boot)-       ---       -- It's just temporary because either the usage check will succeed-       -- (in which case we are done with this module) or it'll fail (in which-       -- case we'll compile the module from scratch anyhow).-       ---       -- We do this regardless of compilation mode, although in --make mode-       -- all the dependent modules should be in the HPT already, so it's-       -- quite redundant-       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }-       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]-       ; return (recomp, Just iface)-    }}}}}}}}}}-  where-    this_pkg = thisPackage (hsc_dflags hsc_env)-    -- This is a bit of a hack really-    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)-    mod_deps = mkModDeps (dep_mods (mi_deps iface))---- | Check if any plugins are requesting recompilation-checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc iface = liftIO $ do-  new_fingerprint <- fingerprintPlugins hsc-  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))-  return $-    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr--fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env = do-  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)--fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint-fingerprintPlugins' plugins = do-  res <- mconcat <$> mapM pluginRecompile' plugins-  return $ case res of-      NoForceRecompile ->  fingerprintString "NoForceRecompile"-      ForceRecompile   -> fingerprintString "ForceRecompile"-      -- is the chance of collision worth worrying about?-      -- An alternative is to fingerprintFingerprints [fingerprintString-      -- "maybeRecompile", fp]-      (MaybeRecompile fp) -> fp---pluginRecompileToRecompileRequired-    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired-pluginRecompileToRecompileRequired old_fp new_fp pr-  | old_fp == new_fp =-    case pr of-      NoForceRecompile  -> UpToDate--      -- we already checked the fingerprint above so a mismatch is not possible-      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.-      MaybeRecompile _  -> UpToDate--      -- 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"--  | old_fp `elem` magic_fingerprints ||-    new_fp `elem` magic_fingerprints-    -- The fingerprints do not match either the old or new one is a magic-    -- fingerprint. This happens when non-pure plugins are added for the first-    -- time or when we go from one recompilation strategy to another: (force ->-    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)-    ---    -- For example when we go from 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"--  | 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--      _                -> RecompBecause reason-- where-   magic_fingerprints =-       [ fingerprintString "NoForceRecompile"-       , fingerprintString "ForceRecompile"-       ]----- | Check if an hsig file needs recompilation because its--- implementing module has changed.-checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired-checkHsig mod_summary iface = do-    dflags <- getDynFlags-    let outer_mod = ms_mod mod_summary-        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)-    MASSERT( moduleUnitId outer_mod == thisPackage dflags )-    case inner_mod == mi_semantic_module iface of-        True -> up_to_date (text "implementing module unchanged")-        False -> return (RecompBecause "implementing module changed")---- | Check if @.hie@ file is out of date or missing.-checkHie :: ModSummary -> IfG RecompileRequired-checkHie mod_summary = do-    dflags <- getDynFlags-    let hie_date_opt = ms_hie_date mod_summary-        hs_date = ms_hs_date mod_summary-    pure $ case gopt Opt_WriteHie dflags of-               False -> UpToDate-               True -> case hie_date_opt of-                           Nothing -> RecompBecause "HIE file is missing"-                           Just hie_date-                               | hie_date < hs_date-                               -> RecompBecause "HIE file is out of date"-                               | otherwise-                               -> UpToDate---- | Check the flags haven't changed-checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired-checkFlagHash hsc_env iface = do-    let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)-                                             (mi_module iface)-                                             putNameLiterally-    case old_hash == new_hash of-        True  -> up_to_date (text "Module flags unchanged")-        False -> out_of_date_hash "flags changed"-                     (text "  Module flags have changed")-                     old_hash new_hash---- | Check the optimisation flags haven't changed-checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired-checkOptimHash hsc_env iface = do-    let old_hash = mi_opt_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)-                                               putNameLiterally-    if | old_hash == new_hash-         -> up_to_date (text "Optimisation flags unchanged")-       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)-         -> up_to_date (text "Optimisation flags changed; ignoring")-       | otherwise-         -> out_of_date_hash "Optimisation flags changed"-                     (text "  Optimisation flags have changed")-                     old_hash new_hash---- | Check the HPC flags haven't changed-checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired-checkHpcHash hsc_env iface = do-    let old_hash = mi_hpc_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)-                                               putNameLiterally-    if | old_hash == new_hash-         -> up_to_date (text "HPC flags unchanged")-       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)-         -> up_to_date (text "HPC flags changed; ignoring")-       | otherwise-         -> out_of_date_hash "HPC flags changed"-                     (text "  HPC flags have changed")-                     old_hash new_hash---- Check that the set of signatures we are merging in match.--- If the -unit-id flags change, this can change too.-checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired-checkMergedSignatures mod_summary iface = do-    dflags <- getDynFlags-    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]-        new_merged = case Map.lookup (ms_mod_name mod_summary)-                                     (requirementContext (pkgState dflags)) of-                        Nothing -> []-                        Just r -> sort $ map (indefModuleToModule dflags) r-    if old_merged == new_merged-        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)-        else return (RecompBecause "signatures to merge in changed")---- If the direct imports of this module are resolved to targets that--- are not among the dependencies of the previous interface file,--- then we definitely need to recompile.  This catches cases like---   - an exposed package has been upgraded---   - we are compiling with different package flags---   - a home module that was shadowing a package module has been removed---   - a new home module has been added that shadows a package module--- See bug #1372.------ In addition, we also check if the union of dependencies of the imported--- modules has any difference to the previous set of dependencies. We would need--- to recompile in that case also since the `mi_deps` field of ModIface needs--- to be updated to match that information. This is one of the invariants--- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants).--- See bug #16511.------ Returns (RecompBecause <textual reason>) if recompilation is required.-checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired-checkDependencies hsc_env summary iface- = do-   checkList $-     [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))-     , do-         (recomp, mnames_seen) <- runUntilRecompRequired $ map-           checkForNewHomeDependency-           (ms_home_imps summary)-         case recomp of-           UpToDate -> do-             let-               seen_home_deps = Set.unions $ map Set.fromList mnames_seen-             checkIfAllOldHomeDependenciesAreSeen seen_home_deps-           _ -> return recomp]- where-   prev_dep_mods = dep_mods (mi_deps iface)-   prev_dep_plgn = dep_plgins (mi_deps iface)-   prev_dep_pkgs = dep_pkgs (mi_deps iface)--   this_pkg = thisPackage (hsc_dflags hsc_env)--   dep_missing (mb_pkg, L _ mod) = do-     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)-     let reason = moduleNameString mod ++ " changed"-     case find_res of-        Found _ mod-          | pkg == this_pkg-           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-          | otherwise-           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)-                 then do traceHiDiffs $-                           text "imported module " <> quotes (ppr mod) <>-                           text " is from package " <> quotes (ppr pkg) <>-                           text ", which is not among previous dependencies"-                         return (RecompBecause reason)-                 else-                         return UpToDate-           where pkg = moduleUnitId mod-        _otherwise  -> return (RecompBecause reason)--   old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods-   isOldHomeDeps = flip Set.member old_deps-   checkForNewHomeDependency (L _ mname) = do-     let-       mod = mkModule this_pkg mname-       str_mname = moduleNameString mname-       reason = str_mname ++ " changed"-     -- We only want to look at home modules to check if any new home dependency-     -- pops in and thus here, skip modules that are not home. Checking-     -- membership in old home dependencies suffice because the `dep_missing`-     -- check already verified that all imported home modules are present there.-     if not (isOldHomeDeps mname)-       then return (UpToDate, [])-       else do-         mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do-           let mnames = mname:(map fst $ filter (not . snd) $-                 dep_mods $ mi_deps imported_iface)-           case find (not . isOldHomeDeps) mnames of-             Nothing -> return (UpToDate, mnames)-             Just new_dep_mname -> do-               traceHiDiffs $-                 text "imported home module " <> quotes (ppr mod) <>-                 text " has a new dependency " <> quotes (ppr new_dep_mname)-               return (RecompBecause reason, [])-         return $ fromMaybe (MustCompile, []) mb_result--   -- Performs all recompilation checks in the list until a check that yields-   -- recompile required is encountered. Returns the list of the results of-   -- all UpToDate checks.-   runUntilRecompRequired []             = return (UpToDate, [])-   runUntilRecompRequired (check:checks) = do-     (recompile, value) <- check-     if recompileRequired recompile-       then return (recompile, [])-       else do-         (recomp, values) <- runUntilRecompRequired checks-         return (recomp, value:values)--   checkIfAllOldHomeDependenciesAreSeen seen_deps = do-     let unseen_old_deps = Set.difference-          old_deps-          seen_deps-     if not (null unseen_old_deps)-       then do-         let missing_dep = Set.elemAt 0 unseen_old_deps-         traceHiDiffs $-           text "missing old home dependency " <> quotes (ppr missing_dep)-         return $ RecompBecause "missing old dependency"-       else return UpToDate--needInterface :: Module -> (ModIface -> IfG RecompileRequired)-             -> IfG RecompileRequired-needInterface mod continue-  = do-      mb_recomp <- getFromModIface-        "need version info for"-        mod-        continue-      case mb_recomp of-        Nothing -> return MustCompile-        Just recomp -> return recomp--getFromModIface :: String -> Module -> (ModIface -> IfG a)-              -> IfG (Maybe a)-getFromModIface doc_msg mod getter-  = do  -- Load the imported interface if possible-    let doc_str = sep [text doc_msg, ppr mod]-    traceHiDiffs (text "Checking innterface for module" <+> ppr mod)--    mb_iface <- loadInterface doc_str mod ImportBySystem-        -- Load the interface, but don't complain on failure;-        -- Instead, get an Either back which we can test--    case mb_iface of-      Failed _ -> do-        traceHiDiffs (sep [text "Couldn't load interface for module",-                           ppr mod])-        return Nothing-                  -- Couldn't find or parse a module mentioned in the-                  -- old interface file.  Don't complain: it might-                  -- just be that the current module doesn't need that-                  -- import and it's been deleted-      Succeeded iface -> Just <$> getter iface---- | Given the usage information extracted from the old--- M.hi file for the module being compiled, figure out--- whether M needs to be recompiled.-checkModUsage :: UnitId -> Usage -> IfG RecompileRequired-checkModUsage _this_pkg UsagePackageModule{-                                usg_mod = mod,-                                usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed"-    checkModuleFingerprint 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-        -- recompile.  This is safe but may entail more recompilation when-        -- a dependent package has changed.--checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }-  = needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"-    checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface))--checkModUsage this_pkg UsageHomeModule{-                                usg_mod_name = mod_name,-                                usg_mod_hash = old_mod_hash,-                                usg_exports = maybe_old_export_hash,-                                usg_entities = old_decl_hash }-  = do-    let mod = mkModule this_pkg mod_name-    needInterface mod $ \iface -> do--    let-        new_mod_hash    = mi_mod_hash (mi_final_exts iface)-        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"--        -- CHECK MODULE-    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash-    if not (recompileRequired recompile)-      then return UpToDate-      else do--        -- CHECK EXPORT LIST-        checkMaybeHash reason maybe_old_export_hash new_export_hash-            (text "  Export list changed") $ do--        -- CHECK ITEMS ONE BY ONE-        recompile <- checkList [ checkEntityUsage reason new_decl_hash u-                               | u <- old_decl_hash]-        if recompileRequired recompile-          then return recompile     -- This one failed, so just bail out now-          else up_to_date (text "  Great!  The bits I use are up to date")---checkModUsage _this_pkg UsageFile{ usg_file_path = file,-                                   usg_file_hash = old_hash } =-  liftIO $-    handleIO handle $ do-      new_hash <- getFileHash file-      if (old_hash /= new_hash)-         then return recomp-         else return UpToDate- where-   recomp = RecompBecause (file ++ " changed")-   handle =-#if defined(DEBUG)-       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp-#else-       \_ -> return recomp -- if we can't find the file, just recompile, don't fail-#endif---------------------------checkModuleFingerprint :: String -> Fingerprint -> Fingerprint-                       -> IfG RecompileRequired-checkModuleFingerprint reason old_mod_hash new_mod_hash-  | new_mod_hash == old_mod_hash-  = up_to_date (text "Module fingerprint unchanged")--  | otherwise-  = out_of_date_hash reason (text "  Module fingerprint has changed")-                     old_mod_hash new_mod_hash---------------------------checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc-               -> IfG RecompileRequired -> IfG RecompileRequired-checkMaybeHash reason maybe_old_hash new_hash doc continue-  | Just hash <- maybe_old_hash, hash /= new_hash-  = out_of_date_hash reason doc hash new_hash-  | otherwise-  = continue---------------------------checkEntityUsage :: String-                 -> (OccName -> Maybe (OccName, Fingerprint))-                 -> (OccName, Fingerprint)-                 -> IfG RecompileRequired-checkEntityUsage reason new_hash (name,old_hash)-  = case new_hash name of--        Nothing       ->        -- We used it before, but it ain't there now-                          out_of_date reason (sep [text "No longer exported:", ppr name])--        Just (_, new_hash)      -- It's there, but is it up to date?-          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))-                                       return UpToDate-          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)-                                                     old_hash new_hash--up_to_date :: SDoc -> IfG RecompileRequired-up_to_date  msg = traceHiDiffs msg >> return UpToDate--out_of_date :: String -> SDoc -> IfG RecompileRequired-out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)--out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired-out_of_date_hash reason msg old_hash new_hash-  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])-------------------------checkList :: [IfG RecompileRequired] -> IfG RecompileRequired--- This helper is used in two places-checkList []             = return UpToDate-checkList (check:checks) = do recompile <- check-                              if recompileRequired recompile-                                then return recompile-                                else checkList checks--{--************************************************************************-*                                                                      *-                Converting things to their Iface equivalents-*                                                                      *-************************************************************************--}--tyThingToIfaceDecl :: TyThing -> IfaceDecl-tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id-tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)-tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax-tyThingToIfaceDecl (AConLike cl)  = case cl of-    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only-    PatSynCon ps   -> patSynToIfaceDecl ps-----------------------------idToIfaceDecl :: Id -> IfaceDecl--- The Id is already tidied, so that locally-bound names--- (lambdas, for-alls) already have non-clashing OccNames--- We can't tidy it here, locally, because it may have--- free variables in its type or IdInfo-idToIfaceDecl id-  = IfaceId { ifName      = getName id,-              ifType      = toIfaceType (idType id),-              ifIdDetails = toIfaceIdDetails (idDetails id),-              ifIdInfo    = toIfaceIdInfo (idInfo id) }-----------------------------dataConToIfaceDecl :: DataCon -> IfaceDecl-dataConToIfaceDecl dataCon-  = IfaceId { ifName      = getName dataCon,-              ifType      = toIfaceType (dataConUserType dataCon),-              ifIdDetails = IfVanillaId,-              ifIdInfo    = NoInfo }-----------------------------coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl--- We *do* tidy Axioms, because they are not (and cannot--- conveniently be) built in tidy form-coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches-                               , co_ax_role = role })- = IfaceAxiom { ifName       = getName ax-              , ifTyCon      = toIfaceTyCon tycon-              , ifRole       = role-              , ifAxBranches = map (coAxBranchToIfaceBranch tycon-                                     (map coAxBranchLHS branch_list))-                                   branch_list }- where-   branch_list = fromBranches branches---- 2nd parameter is the list of branch LHSs, in case of a closed type family,--- for conversion from incompatible branches to incompatible indices.--- For an open type family the list should be empty.--- See Note [Storing compatibility] in CoAxiom-coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch-coAxBranchToIfaceBranch tc lhs_s-                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                                    , cab_eta_tvs = eta_tvs-                                    , cab_lhs = lhs, cab_roles = roles-                                    , cab_rhs = rhs, cab_incomps = incomps })--  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs-                  , ifaxbCoVars  = map toIfaceIdBndr cvs-                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs-                  , ifaxbLHS     = toIfaceTcArgs tc lhs-                  , ifaxbRoles   = roles-                  , ifaxbRHS     = toIfaceType rhs-                  , ifaxbIncomps = iface_incomps }-  where-    iface_incomps = map (expectJust "iface_incomps"-                        . flip findIndex lhs_s-                        . eqTypes-                        . coAxBranchLHS) incomps--------------------tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)--- We *do* tidy TyCons, because they are not (and cannot--- conveniently be) built in tidy form--- The returned TidyEnv is the one after tidying the tyConTyVars-tyConToIfaceDecl env tycon-  | Just clas <- tyConClass_maybe tycon-  = classToIfaceDecl env clas--  | Just syn_rhs <- synTyConRhs_maybe tycon-  = ( tc_env1-    , IfaceSynonym { ifName    = getName tycon,-                     ifRoles   = tyConRoles tycon,-                     ifSynRhs  = if_syn_type syn_rhs,-                     ifBinders = if_binders,-                     ifResKind = if_res_kind-                   })--  | Just fam_flav <- famTyConFlav_maybe tycon-  = ( tc_env1-    , IfaceFamily { ifName    = getName tycon,-                    ifResVar  = if_res_var,-                    ifFamFlav = to_if_fam_flav fam_flav,-                    ifBinders = if_binders,-                    ifResKind = if_res_kind,-                    ifFamInj  = tyConInjectivityInfo tycon-                  })--  | isAlgTyCon tycon-  = ( tc_env1-    , IfaceData { ifName    = getName tycon,-                  ifBinders = if_binders,-                  ifResKind = if_res_kind,-                  ifCType   = tyConCType tycon,-                  ifRoles   = tyConRoles tycon,-                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),-                  ifCons    = ifaceConDecls (algTyConRhs tycon),-                  ifGadtSyntax = isGadtSyntaxTyCon tycon,-                  ifParent  = parent })--  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon-  -- We only convert these TyCons to IfaceTyCons when we are-  -- just about to pretty-print them, not because we are going-  -- to put them into interface files-  = ( env-    , IfaceData { ifName       = getName tycon,-                  ifBinders    = if_binders,-                  ifResKind    = if_res_kind,-                  ifCType      = Nothing,-                  ifRoles      = tyConRoles tycon,-                  ifCtxt       = [],-                  ifCons       = IfDataTyCon [],-                  ifGadtSyntax = False,-                  ifParent     = IfNoParent })-  where-    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`-    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause-    -- an error.-    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)-    tc_tyvars      = binderVars tc_binders-    if_binders     = toIfaceTyCoVarBinders tc_binders-                     -- No tidying of the binders; they are already tidy-    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)-    if_syn_type ty = tidyToIfaceType tc_env1 ty-    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon--    parent = case tyConFamInstSig_maybe tycon of-               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)-                                                   (toIfaceTyCon tc)-                                                   (tidyToIfaceTcArgs tc_env1 tc ty)-               Nothing           -> IfNoParent--    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon-    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon-    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon-    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon-    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing-    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))-      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))-      where defs = fromBranches $ coAxiomBranches ax-            lhss = map coAxBranchLHS defs-            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs-            axn  = coAxiomName ax--    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)-    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)-    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]-    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)-    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon-        -- The AbstractTyCon case happens when a TyCon has been trimmed-        -- during tidying.-        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver-        -- for GHCi, when browsing a module, in which case the-        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.-        -- (Tuple declarations are not serialised into interface files.)--    ifaceConDecl data_con-        = IfCon   { ifConName    = dataConName data_con,-                    ifConInfix   = dataConIsInfix data_con,-                    ifConWrapper = isJust (dataConWrapId_maybe data_con),-                    ifConExTCvs  = map toIfaceBndr ex_tvs',-                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',-                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,-                    ifConCtxt    = tidyToIfaceContext con_env2 theta,-                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,-                    ifConFields  = dataConFieldLabels data_con,-                    ifConStricts = map (toIfaceBang con_env2)-                                       (dataConImplBangs data_con),-                    ifConSrcStricts = map toIfaceSrcBang-                                          (dataConSrcBangs data_con)}-        where-          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)-            = dataConFullSig data_con-          user_bndrs = dataConUserTyVarBinders data_con--          -- Tidy the univ_tvs of the data constructor to be identical-          -- to the tyConTyVars of the type constructor.  This means-          -- (a) we don't need to redundantly put them into the interface file-          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,-          --     we know that the type variables will line up-          -- The latter (b) is important because we pretty-print type constructors-          -- by converting to IfaceSyn and pretty-printing that-          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))-                     -- A bit grimy, perhaps, but it's simple!--          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs-          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs-          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)--          -- By this point, we have tidied every universal and existential-          -- tyvar. Because of the dcUserTyCoVarBinders invariant-          -- (see Note [DataCon user type variable binders]), *every*-          -- user-written tyvar must be contained in the substitution that-          -- tidying produced. Therefore, tidying the user-written tyvars is a-          -- simple matter of looking up each variable in the substitution,-          -- which tidyTyCoVarOcc accomplishes.-          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder-          tidyUserTyCoVarBinder env (Bndr tv vis) =-            Bndr (tidyTyCoVarOcc env tv) vis--classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)-classToIfaceDecl env clas-  = ( env1-    , IfaceClass { ifName   = getName tycon,-                   ifRoles  = tyConRoles (classTyCon clas),-                   ifBinders = toIfaceTyCoVarBinders tc_binders,-                   ifBody   = body,-                   ifFDs    = map toIfaceFD clas_fds })-  where-    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)-      = classExtraBigSig clas-    tycon = classTyCon clas--    body | isAbstractTyCon tycon = IfAbstractClass-         | otherwise-         = IfConcreteClass {-                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,-                ifATs    = map toIfaceAT clas_ats,-                ifSigs   = map toIfaceClassOp op_stuff,-                ifMinDef = fmap getOccFS (classMinimalDef clas)-            }--    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)--    toIfaceAT :: ClassATItem -> IfaceAT-    toIfaceAT (ATI tc def)-      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)-      where-        (env2, if_decl) = tyConToIfaceDecl env1 tc--    toIfaceClassOp (sel_id, def_meth)-        = ASSERT( sel_tyvars == binderVars tc_binders )-          IfaceClassOp (getName sel_id)-                       (tidyToIfaceType env1 op_ty)-                       (fmap toDmSpec def_meth)-        where-                -- Be careful when splitting the type, because of things-                -- like         class Foo a where-                --                op :: (?x :: String) => a -> a-                -- and          class Baz a where-                --                op :: (Ord a) => a -> a-          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)-          op_ty                = funResultTy rho_ty--    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType-    toDmSpec (_, VanillaDM)       = VanillaDM-    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)--    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1-                             ,map (tidyTyVar env1) tvs2)------------------------------tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)--- If the type variable "binder" is in scope, don't re-bind it--- In a class decl, for example, the ATD binders mention--- (amd must mention) the class tyvars-tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)- = case lookupVarEnv subst tv of-     Just tv' -> (env,  Bndr tv' vis)-     Nothing  -> tidyTyCoVarBinder env tvb--tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])-tidyTyConBinders = mapAccumL tidyTyConBinder--tidyTyVar :: TidyEnv -> TyVar -> FastString-tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)-----------------------------instanceToIfaceInst :: ClsInst -> IfaceClsInst-instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag-                             , is_cls_nm = cls_name, is_cls = cls-                             , is_tcs = mb_tcs-                             , is_orphan = orph })-  = ASSERT( cls_name == className cls )-    IfaceClsInst { ifDFun    = dfun_name,-                ifOFlag   = oflag,-                ifInstCls = cls_name,-                ifInstTys = map do_rough mb_tcs,-                ifInstOrph = orph }-  where-    do_rough Nothing  = Nothing-    do_rough (Just n) = Just (toIfaceTyCon_name n)--    dfun_name = idName dfun_id------------------------------famInstToIfaceFamInst :: FamInst -> IfaceFamInst-famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,-                                 fi_fam      = fam,-                                 fi_tcs      = roughs })-  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom-                 , ifFamInstFam      = fam-                 , ifFamInstTys      = map do_rough roughs-                 , ifFamInstOrph     = orph }-  where-    do_rough Nothing  = Nothing-    do_rough (Just n) = Just (toIfaceTyCon_name n)--    fam_decl = tyConName $ coAxiomTyCon axiom-    mod = ASSERT( isExternalName (coAxiomName axiom) )-          nameModule (coAxiomName axiom)-    is_local name = nameIsLocalOrFrom mod name--    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)--    orph | is_local fam_decl-         = NotOrphan (nameOccName fam_decl)-         | otherwise-         = chooseOrphanAnchor lhs_names-----------------------------coreRuleToIfaceRule :: CoreRule -> IfaceRule-coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})-  = pprTrace "toHsRule: builtin" (ppr fn) $-    bogusIfaceRule fn--coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,-                            ru_act = act, ru_bndrs = bndrs,-                            ru_args = args, ru_rhs = rhs,-                            ru_orphan = orph, ru_auto = auto })-  = IfaceRule { ifRuleName  = name, ifActivation = act,-                ifRuleBndrs = map toIfaceBndr bndrs,-                ifRuleHead  = fn,-                ifRuleArgs  = map do_arg args,-                ifRuleRhs   = toIfaceExpr rhs,-                ifRuleAuto  = auto,-                ifRuleOrph  = orph }-  where-        -- For type args we must remove synonyms from the outermost-        -- level.  Reason: so that when we read it back in we'll-        -- construct the same ru_rough field as we have right now;-        -- see tcIfaceRule-    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))-    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)-    do_arg arg           = toIfaceExpr arg--bogusIfaceRule :: Name -> IfaceRule-bogusIfaceRule id_name-  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,-        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],-        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,-        ifRuleAuto = True }
− compiler/iface/TcIface.hs 
@@ -1,1825 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---Type checking of type signatures in interface files--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--module TcIface (-        tcLookupImported_maybe,-        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,-        typecheckIfacesForMerging,-        typecheckIfaceForInstantiate,-        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,-        tcIfaceAnnotations, tcIfaceCompleteSigs,-        tcIfaceExpr,    -- Desired by HERMIT (#7683)-        tcIfaceGlobal- ) where--#include "HsVersions.h"--import GhcPrelude--import TcTypeNats(typeNatCoAxiomRules)-import IfaceSyn-import LoadIface-import IfaceEnv-import BuildTyCl-import TcRnMonad-import TcType-import Type-import Coercion-import CoAxiom-import TyCoRep    -- needs to build types & coercions in a knot-import TyCoSubst ( substTyCoVars )-import HscTypes-import Annotations-import InstEnv-import FamInstEnv-import CoreSyn-import CoreUtils-import CoreUnfold-import CoreLint-import MkCore-import Id-import MkId-import IdInfo-import Class-import TyCon-import ConLike-import DataCon-import PrelNames-import TysWiredIn-import Literal-import Var-import VarSet-import Name-import NameEnv-import NameSet-import OccurAnal        ( occurAnalyseExpr )-import Demand-import Module-import UniqFM-import UniqSupply-import Outputable-import Maybes-import SrcLoc-import DynFlags-import Util-import FastString-import BasicTypes hiding ( SuccessFlag(..) )-import ListSetOps-import GHC.Fingerprint-import qualified BooleanFormula as BF--import Control.Monad-import qualified Data.Map as Map--{--This module takes--        IfaceDecl -> TyThing-        IfaceType -> Type-        etc--An IfaceDecl is populated with RdrNames, and these are not renamed to-Names before typechecking, because there should be no scope errors etc.--        -- For (b) consider: f = \$(...h....)-        -- where h is imported, and calls f via an hi-boot file.-        -- This is bad!  But it is not seen as a staging error, because h-        -- is indeed imported.  We don't want the type-checker to black-hole-        -- when simplifying and compiling the splice!-        ---        -- Simple solution: discard any unfolding that mentions a variable-        -- bound in this module (and hence not yet processed).-        -- The discarding happens when forkM finds a type error.---************************************************************************-*                                                                      *-                Type-checking a complete interface-*                                                                      *-************************************************************************--Suppose we discover we don't need to recompile.  Then we must type-check the old interface file.  This is a bit different to the-incremental type checking we do as we suck in interface files.  Instead-we do things similarly as when we are typechecking source decls: we-bring into scope the type envt for the interface all at once, using a-knot.  Remember, the decls aren't necessarily in dependency order ---and even if they were, the type decls might be mutually recursive.--Note [Knot-tying typecheckIface]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are typechecking an interface A.hi, and we come across-a Name for another entity defined in A.hi.  How do we get the-'TyCon', in this case?  There are three cases:--    1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in-    preparation of checking if the hs file we're building-    is compatible.  In this case, we want all of the internal-    TyCons to MATCH the ones that we just constructed during-    typechecking: the knot is thus tied through if_rec_types.--    2) retypecheckLoop in GhcMake: We are retypechecking a-    mutually recursive cluster of hi files, in order to ensure-    that all of the references refer to each other correctly.-    In this case, the knot is tied through the HPT passed in,-    which contains all of the interfaces we are in the process-    of typechecking.--    3) genModDetails in HscMain: We are typechecking an-    old interface to generate the ModDetails.  In this case,-    we do the same thing as (2) and pass in an HPT with-    the HomeModInfo being generated to tie knots.--The upshot is that the CLIENT of this function is responsible-for making sure that the knot is tied correctly.  If you don't,-then you'll get a message saying that we couldn't load the-declaration you wanted.--BTW, in one-shot mode we never call typecheckIface; instead,-loadInterface handles type-checking interface.  In that case,-knots are tied through the EPS.  No problem!--}---- Clients of this function be careful, see Note [Knot-tying typecheckIface]-typecheckIface :: ModIface      -- Get the decls from here-               -> IfG ModDetails-typecheckIface iface-  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do-        {       -- Get the right set of decls and rules.  If we are compiling without -O-                -- we discard pragmas before typechecking, so that we don't "see"-                -- information that we shouldn't.  From a versioning point of view-                -- It's not actually *wrong* to do so, but in fact GHCi is unable-                -- to handle unboxed tuples, so it must not see unfoldings.-          ignore_prags <- goptM Opt_IgnoreInterfacePragmas--                -- Typecheck the decls.  This is done lazily, so that the knot-tying-                -- within this single module works out right.  It's the callers-                -- job to make sure the knot is tied.-        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)-        ; let type_env = mkNameEnv names_w_things--                -- Now do those rules, instances and annotations-        ; insts     <- mapM tcIfaceInst (mi_insts iface)-        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)-        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)-        ; anns      <- tcIfaceAnnotations (mi_anns iface)--                -- Exports-        ; exports <- ifaceExportNames (mi_exports iface)--                -- Complete Sigs-        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)--                -- Finished-        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),-                         -- Careful! If we tug on the TyThing thunks too early-                         -- we'll infinite loop with hs-boot.  See #10083 for-                         -- an example where this would cause non-termination.-                         text "Type envt:" <+> ppr (map fst names_w_things)])-        ; return $ ModDetails { md_types     = type_env-                              , md_insts     = insts-                              , md_fam_insts = fam_insts-                              , md_rules     = rules-                              , md_anns      = anns-                              , md_exports   = exports-                              , md_complete_sigs = complete_sigs-                              }-    }--{--************************************************************************-*                                                                      *-                Typechecking for merging-*                                                                      *-************************************************************************--}---- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)-isAbstractIfaceDecl :: IfaceDecl -> Bool-isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True-isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True-isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True-isAbstractIfaceDecl _ = False--ifMaybeRoles :: IfaceDecl -> Maybe [Role]-ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs-ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs-ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs-ifMaybeRoles _ = Nothing---- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If--- both are non-abstract we pick one arbitrarily (and check for consistency--- later.)-mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl-mergeIfaceDecl d1 d2-    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1-    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2-    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1-    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2-    = let ops = nameEnvElts $-                  plusNameEnv_C mergeIfaceClassOp-                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])-                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])-      in d1 { ifBody = (ifBody d1) {-                ifSigs  = ops,-                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]-                }-            } `withRolesFrom` d2-    -- It doesn't matter; we'll check for consistency later when-    -- we merge, see 'mergeSignatures'-    | otherwise              = d1 `withRolesFrom` d2---- Note [Role merging]--- ~~~~~~~~~~~~~~~~~~~--- First, why might it be necessary to do a non-trivial role--- merge?  It may rescue a merge that might otherwise fail:------      signature A where---          type role T nominal representational---          data T a b------      signature A where---          type role T representational nominal---          data T a b------ A module that defines T as representational in both arguments--- would successfully fill both signatures, so it would be better--- if we merged the roles of these types in some nontrivial--- way.------ However, we have to be very careful about how we go about--- doing this, because role subtyping is *conditional* on--- the supertype being NOT representationally injective, e.g.,--- if we have instead:------      signature A where---          type role T nominal representational---          data T a b = T a b------      signature A where---          type role T representational nominal---          data T a b = T a b------ Should we merge the definitions of T so that the roles are R/R (or N/N)?--- Absolutely not: neither resulting type is a subtype of the original--- types (see Note [Role subtyping]), because data is not representationally--- injective.------ Thus, merging only occurs when BOTH TyCons in question are--- representationally injective.  If they're not, no merge.--withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl-d1 `withRolesFrom` d2-    | Just roles1 <- ifMaybeRoles d1-    , Just roles2 <- ifMaybeRoles d2-    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)-    = d1 { ifRoles = mergeRoles roles1 roles2 }-    | otherwise = d1-  where-    mergeRoles roles1 roles2 = zipWith max roles1 roles2--isRepInjectiveIfaceDecl :: IfaceDecl -> Bool-isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True-isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True-isRepInjectiveIfaceDecl _ = False--mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp-mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1-mergeIfaceClassOp _ op2 = op2---- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.-mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl-mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl---- | This is a very interesting function.  Like typecheckIface, we want--- to type check an interface file into a ModDetails.  However, the use-case--- for these ModDetails is different: we want to compare all of the--- ModDetails to ensure they define compatible declarations, and then--- merge them together.  So in particular, we have to take a different--- strategy for knot-tying: we first speculatively merge the declarations--- to get the "base" truth for what we believe the types will be--- (this is "type computation.")  Then we read everything in relative--- to this truth and check for compatibility.------ During the merge process, we may need to nondeterministically--- pick a particular declaration to use, if multiple signatures define--- the declaration ('mergeIfaceDecl').  If, for all choices, there--- are no type synonym cycles in the resulting merged graph, then--- we can show that our choice cannot matter. Consider the--- set of entities which the declarations depend on: by assumption--- of acyclicity, we can assume that these have already been shown to be equal--- to each other (otherwise merging will fail).  Then it must--- be the case that all candidate declarations here are type-equal--- (the choice doesn't matter) or there is an inequality (in which--- case merging will fail.)------ Unfortunately, the choice can matter if there is a cycle.  Consider the--- following merge:------      signature H where { type A = C;  type B = A; data C      }---      signature H where { type A = (); data B;     type C = B  }------ If we pick @type A = C@ as our representative, there will be--- a cycle and merging will fail. But if we pick @type A = ()@ as--- our representative, no cycle occurs, and we instead conclude--- that all of the types are unit.  So it seems that we either--- (a) need a stronger acyclicity check which considers *all*--- possible choices from a merge, or (b) we must find a selection--- of declarations which is acyclic, and show that this is always--- the "best" choice we could have made (ezyang conjectures this--- is the case but does not have a proof).  For now this is--- not implemented.------ It's worth noting that at the moment, a data constructor and a--- type synonym are never compatible.  Consider:------      signature H where { type Int=C;         type B = Int; data C = Int}---      signature H where { export Prelude.Int; data B;       type C = B; }------ This will be rejected, because the reexported Int in the second--- signature (a proper data type) is never considered equal to a--- type synonym.  Perhaps this should be relaxed, where a type synonym--- in a signature is considered implemented by a data type declaration--- which matches the reference of the type synonym.-typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])-typecheckIfacesForMerging mod ifaces tc_env_var =-  -- cannot be boot (False)-  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do-    ignore_prags <- goptM Opt_IgnoreInterfacePragmas-    -- Build the initial environment-    -- NB: Don't include dfuns here, because we don't want to-    -- serialize them out.  See Note [rnIfaceNeverExported] in RnModIface-    -- NB: But coercions are OK, because they will have the right OccName.-    let mk_decl_env decls-            = mkOccEnv [ (getOccName decl, decl)-                       | decl <- decls-                       , case decl of-                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns-                            _ -> True ]-        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces-                        :: [OccEnv IfaceDecl]-        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs-                        ::  OccEnv IfaceDecl-    -- TODO: change loadDecls to accept w/o Fingerprint-    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))-                                                  (occEnvElts decl_env))-    let global_type_env = mkNameEnv names_w_things-    writeMutVar tc_env_var global_type_env--    -- OK, now typecheck each ModIface using this environment-    details <- forM ifaces $ \iface -> do-        -- See Note [Resolving never-exported Names in TcIface]-        type_env <- fixM $ \type_env -> do-            setImplicitEnvM type_env $ do-                decls <- loadDecls ignore_prags (mi_decls iface)-                return (mkNameEnv decls)-        -- But note that we use this type_env to typecheck references to DFun-        -- in 'IfaceInst'-        setImplicitEnvM type_env $ do-        insts     <- mapM tcIfaceInst (mi_insts iface)-        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)-        rules     <- tcIfaceRules ignore_prags (mi_rules iface)-        anns      <- tcIfaceAnnotations (mi_anns iface)-        exports   <- ifaceExportNames (mi_exports iface)-        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)-        return $ ModDetails { md_types     = type_env-                            , md_insts     = insts-                            , md_fam_insts = fam_insts-                            , md_rules     = rules-                            , md_anns      = anns-                            , md_exports   = exports-                            , md_complete_sigs = complete_sigs-                            }-    return (global_type_env, details)---- | Typecheck a signature 'ModIface' under the assumption that we have--- instantiated it under some implementation (recorded in 'mi_semantic_module')--- and want to check if the implementation fills the signature.------ This needs to operate slightly differently than 'typecheckIface'--- because (1) we have a 'NameShape', from the exports of the--- implementing module, which we will use to give our top-level--- declarations the correct 'Name's even when the implementor--- provided them with a reexport, and (2) we have to deal with--- DFun silliness (see Note [rnIfaceNeverExported])-typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails-typecheckIfaceForInstantiate nsubst iface =-  initIfaceLclWithSubst (mi_semantic_module iface)-                        (text "typecheckIfaceForInstantiate")-                        (mi_boot iface) nsubst $ do-    ignore_prags <- goptM Opt_IgnoreInterfacePragmas-    -- See Note [Resolving never-exported Names in TcIface]-    type_env <- fixM $ \type_env -> do-        setImplicitEnvM type_env $ do-            decls     <- loadDecls ignore_prags (mi_decls iface)-            return (mkNameEnv decls)-    -- See Note [rnIfaceNeverExported]-    setImplicitEnvM type_env $ do-    insts     <- mapM tcIfaceInst (mi_insts iface)-    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)-    rules     <- tcIfaceRules ignore_prags (mi_rules iface)-    anns      <- tcIfaceAnnotations (mi_anns iface)-    exports   <- ifaceExportNames (mi_exports iface)-    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)-    return $ ModDetails { md_types     = type_env-                        , md_insts     = insts-                        , md_fam_insts = fam_insts-                        , md_rules     = rules-                        , md_anns      = anns-                        , md_exports   = exports-                        , md_complete_sigs = complete_sigs-                        }---- Note [Resolving never-exported Names in TcIface]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- For the high-level overview, see--- Note [Handling never-exported TyThings under Backpack]------ As described in 'typecheckIfacesForMerging', the splendid innovation--- of signature merging is to rewrite all Names in each of the signatures--- we are merging together to a pre-merged structure; this is the key--- ingredient that lets us solve some problems when merging type--- synonyms.------ However, when a 'Name' refers to a NON-exported entity, as is the--- case with the DFun of a ClsInst, or a CoAxiom of a type family,--- this strategy causes problems: if we pick one and rewrite all--- references to a shared 'Name', we will accidentally fail to check--- if the DFun or CoAxioms are compatible, as they will never be--- checked--only exported entities are checked for compatibility,--- and a non-exported TyThing is checked WHEN we are checking the--- ClsInst or type family for compatibility in checkBootDeclM.--- By virtue of the fact that everything's been pointed to the merged--- declaration, you'll never notice there's a difference even if there--- is one.------ Fortunately, there are only a few places in the interface declarations--- where this can occur, so we replace those calls with 'tcIfaceImplicit',--- which will consult a local TypeEnv that records any never-exported--- TyThings which we should wire up with.------ Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a--- type family can refer to a coercion axiom, all of which are done in one go--- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck--- coercions first before type families, but that seemed more fragile.-----{--************************************************************************-*                                                                      *-                Type and class declarations-*                                                                      *-************************************************************************--}--tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo--- Load the hi-boot iface for the module being compiled,--- if it indeed exists in the transitive closure of imports--- Return the ModDetails; Nothing if no hi-boot iface-tcHiBootIface hsc_src mod-  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file-  = return NoSelfBoot-  | otherwise-  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)--        ; mode <- getGhcMode-        ; if not (isOneShot mode)-                -- In --make and interactive mode, if this module has an hs-boot file-                -- we'll have compiled it already, and it'll be in the HPT-                ---                -- We check wheher the interface is a *boot* interface.-                -- It can happen (when using GHC from Visual Studio) that we-                -- compile a module in TypecheckOnly mode, with a stable,-                -- fully-populated HPT.  In that case the boot interface isn't there-                -- (it's been replaced by the mother module) so we can't check it.-                -- And that's fine, because if M's ModInfo is in the HPT, then-                -- it's been compiled once, and we don't need to check the boot iface-          then do { hpt <- getHpt-                 ; case lookupHpt hpt (moduleName mod) of-                      Just info | mi_boot (hm_iface info)-                                -> mkSelfBootInfo (hm_iface info) (hm_details info)-                      _ -> return NoSelfBoot }-          else do--        -- OK, so we're in one-shot mode.-        -- Re #9245, we always check if there is an hi-boot interface-        -- to check consistency against, rather than just when we notice-        -- that an hi-boot is necessary due to a circular import.-        { read_result <- findAndReadIface-                                need (fst (splitModuleInsts mod)) mod-                                True    -- Hi-boot file--        ; case read_result of {-            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface-                                           ; mkSelfBootInfo iface tc_iface } ;-            Failed err               ->--        -- There was no hi-boot file. But if there is circularity in-        -- the module graph, there really should have been one.-        -- Since we've read all the direct imports by now,-        -- eps_is_boot will record if any of our imports mention the-        -- current module, which either means a module loop (not-        -- a SOURCE import) or that our hi-boot file has mysteriously-        -- disappeared.-    do  { eps <- getEps-        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of-            Nothing -> return NoSelfBoot -- The typical case--            Just (_, False) -> failWithTc moduleLoop-                -- Someone below us imported us!-                -- This is a loop with no hi-boot in the way--            Just (_mod, True) -> failWithTc (elaborate err)-                -- The hi-boot file has mysteriously disappeared.-    }}}}-  where-    need = text "Need the hi-boot interface for" <+> ppr mod-                 <+> text "to compare against the Real Thing"--    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)-                     <+> text "depends on itself"--    elaborate err = hang (text "Could not find hi-boot interface for" <+>-                          quotes (ppr mod) <> colon) 4 err---mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo-mkSelfBootInfo iface mds-  = do -- NB: This is computed DIRECTLY from the ModIface rather-       -- than from the ModDetails, so that we can query 'sb_tcs'-       -- WITHOUT forcing the contents of the interface.-       let tcs = map ifName-                 . filter isIfaceTyCon-                 . map snd-                 $ mi_decls iface-       return $ SelfBoot { sb_mds = mds-                         , sb_tcs = mkNameSet tcs }-  where-    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on-    -- this 'IfaceDecl', an ATyCon would be returned.-    -- NB: This code assumes that a TyCon cannot be implicit.-    isIfaceTyCon IfaceId{}      = False-    isIfaceTyCon IfaceData{}    = True-    isIfaceTyCon IfaceSynonym{} = True-    isIfaceTyCon IfaceFamily{}  = True-    isIfaceTyCon IfaceClass{}   = True-    isIfaceTyCon IfaceAxiom{}   = False-    isIfaceTyCon IfacePatSyn{}  = False--{--************************************************************************-*                                                                      *-                Type and class declarations-*                                                                      *-************************************************************************--When typechecking a data type decl, we *lazily* (via forkM) typecheck-the constructor argument types.  This is in the hope that we may never-poke on those argument types, and hence may never need to load the-interface files for types mentioned in the arg types.--E.g.-        data Foo.S = MkS Baz.T-Maybe we can get away without even loading the interface for Baz!--This is not just a performance thing.  Suppose we have-        data Foo.S = MkS Baz.T-        data Baz.T = MkT Foo.S-(in different interface files, of course).-Now, first we load and typecheck Foo.S, and add it to the type envt.-If we do explore MkS's argument, we'll load and typecheck Baz.T.-If we explore MkT's argument we'll find Foo.S already in the envt.--If we typechecked constructor args eagerly, when loading Foo.S we'd try to-typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...-which isn't done yet.--All very cunning. However, there is a rather subtle gotcha which bit-me when developing this stuff.  When we typecheck the decl for S, we-extend the type envt with S, MkS, and all its implicit Ids.  Suppose-(a bug, but it happened) that the list of implicit Ids depended in-turn on the constructor arg types.  Then the following sequence of-events takes place:-        * we build a thunk <t> for the constructor arg tys-        * we build a thunk for the extended type environment (depends on <t>)-        * we write the extended type envt into the global EPS mutvar--Now we look something up in the type envt-        * that pulls on <t>-        * which reads the global type envt out of the global EPS mutvar-        * but that depends in turn on <t>--It's subtle, because, it'd work fine if we typechecked the constructor args-eagerly -- they don't need the extended type envt.  They just get the extended-type envt by accident, because they look at it later.--What this means is that the implicitTyThings MUST NOT DEPEND on any of-the forkM stuff.--}--tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings-            -> IfaceDecl-            -> IfL TyThing-tcIfaceDecl = tc_iface_decl Nothing--tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations-              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings-              -> IfaceDecl-              -> IfL TyThing-tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,-                                       ifIdDetails = details, ifIdInfo = info})-  = do  { ty <- tcIfaceType iface_type-        ; details <- tcIdDetails ty details-        ; info <- tcIdInfo ignore_prags TopLevel name ty info-        ; return (AnId (mkGlobalId details name ty info)) }--tc_iface_decl _ _ (IfaceData {ifName = tc_name,-                          ifCType = cType,-                          ifBinders = binders,-                          ifResKind = res_kind,-                          ifRoles = roles,-                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,-                          ifCons = rdr_cons,-                          ifParent = mb_parent })-  = bindIfaceTyConBinders_AT binders $ \ binders' -> do-    { res_kind' <- tcIfaceType res_kind--    ; tycon <- fixM $ \ tycon -> do-            { stupid_theta <- tcIfaceCtxt ctxt-            ; parent' <- tc_parent tc_name mb_parent-            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons-            ; return (mkAlgTyCon tc_name binders' res_kind'-                                 roles cType stupid_theta-                                 cons parent' gadt_syn) }-    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)-    ; return (ATyCon tycon) }-  where-    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav-    tc_parent tc_name IfNoParent-      = do { tc_rep_name <- newTyConRepName tc_name-           ; return (VanillaAlgTyCon tc_rep_name) }-    tc_parent _ (IfDataInstance ax_name _ arg_tys)-      = do { ax <- tcIfaceCoAxiom ax_name-           ; let fam_tc  = coAxiomTyCon ax-                 ax_unbr = toUnbranchedAxiom ax-           ; lhs_tys <- tcIfaceAppArgs arg_tys-           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }--tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,-                                      ifRoles = roles,-                                      ifSynRhs = rhs_ty,-                                      ifBinders = binders,-                                      ifResKind = res_kind })-   = bindIfaceTyConBinders_AT binders $ \ binders' -> do-     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]-     ; rhs      <- forkM (mk_doc tc_name) $-                   tcIfaceType rhs_ty-     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs-     ; return (ATyCon tycon) }-   where-     mk_doc n = text "Type synonym" <+> ppr n--tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,-                                     ifFamFlav = fam_flav,-                                     ifBinders = binders,-                                     ifResKind = res_kind,-                                     ifResVar = res, ifFamInj = inj })-   = bindIfaceTyConBinders_AT binders $ \ binders' -> do-     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]-     ; rhs      <- forkM (mk_doc tc_name) $-                   tc_fam_flav tc_name fam_flav-     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res-     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj-     ; return (ATyCon tycon) }-   where-     mk_doc n = text "Type synonym" <+> ppr n--     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav-     tc_fam_flav tc_name IfaceDataFamilyTyCon-       = do { tc_rep_name <- newTyConRepName tc_name-            ; return (DataFamilyTyCon tc_rep_name) }-     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon-     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)-       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches-            ; return (ClosedSynFamilyTyCon ax) }-     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon-         = return AbstractClosedSynFamilyTyCon-     tc_fam_flav _ IfaceBuiltInSynFamTyCon-         = pprPanic "tc_iface_decl"-                    (text "IfaceBuiltInSynFamTyCon in interface file")--tc_iface_decl _parent _ignore_prags-            (IfaceClass {ifName = tc_name,-                         ifRoles = roles,-                         ifBinders = binders,-                         ifFDs = rdr_fds,-                         ifBody = IfAbstractClass})-  = bindIfaceTyConBinders binders $ \ binders' -> do-    { fds  <- mapM tc_fd rdr_fds-    ; cls  <- buildClass tc_name binders' roles fds Nothing-    ; return (ATyCon (classTyCon cls)) }--tc_iface_decl _parent ignore_prags-            (IfaceClass {ifName = tc_name,-                         ifRoles = roles,-                         ifBinders = binders,-                         ifFDs = rdr_fds,-                         ifBody = IfConcreteClass {-                             ifClassCtxt = rdr_ctxt,-                             ifATs = rdr_ats, ifSigs = rdr_sigs,-                             ifMinDef = mindef_occ-                         }})-  = bindIfaceTyConBinders binders $ \ binders' -> do-    { traceIf (text "tc-iface-class1" <+> ppr tc_name)-    ; ctxt <- mapM tc_sc rdr_ctxt-    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)-    ; sigs <- mapM tc_sig rdr_sigs-    ; fds  <- mapM tc_fd rdr_fds-    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)-    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ-    ; cls  <- fixM $ \ cls -> do-              { ats  <- mapM (tc_at cls) rdr_ats-              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)-              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }-    ; return (ATyCon (classTyCon cls)) }-  where-   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)-        -- The *length* of the superclasses is used by buildClass, and hence must-        -- not be inside the thunk.  But the *content* maybe recursive and hence-        -- must be lazy (via forkM).  Example:-        --     class C (T a) => D a where-        --       data T a-        -- Here the associated type T is knot-tied with the class, and-        -- so we must not pull on T too eagerly.  See #5970--   tc_sig :: IfaceClassOp -> IfL TcMethInfo-   tc_sig (IfaceClassOp op_name rdr_ty dm)-     = do { let doc = mk_op_doc op_name rdr_ty-          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty-                -- Must be done lazily for just the same reason as the-                -- type of a data con; to avoid sucking in types that-                -- it mentions unless it's necessary to do so-          ; dm'   <- tc_dm doc dm-          ; return (op_name, op_ty, dm') }--   tc_dm :: SDoc-         -> Maybe (DefMethSpec IfaceType)-         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))-   tc_dm _   Nothing               = return Nothing-   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)-   tc_dm doc (Just (GenericDM ty))-        = do { -- Must be done lazily to avoid sucking in types-             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty-             ; return (Just (GenericDM (noSrcSpan, ty'))) }--   tc_at cls (IfaceAT tc_decl if_def)-     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl-          mb_def <- case if_def of-                      Nothing  -> return Nothing-                      Just def -> forkM (mk_at_doc tc)                 $-                                  extendIfaceTyVarEnv (tyConTyVars tc) $-                                  do { tc_def <- tcIfaceType def-                                     ; return (Just (tc_def, noSrcSpan)) }-                  -- Must be done lazily in case the RHS of the defaults mention-                  -- the type constructor being defined here-                  -- e.g.   type AT a; type AT b = AT [b]   #8002-          return (ATI tc mb_def)--   mk_sc_doc pred = text "Superclass" <+> ppr pred-   mk_at_doc tc = text "Associated type" <+> ppr tc-   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]--tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc-                              , ifAxBranches = branches, ifRole = role })-  = do { tc_tycon    <- tcIfaceTyCon tc-       -- Must be done lazily, because axioms are forced when checking-       -- for family instance consistency, and the RHS may mention-       -- a hs-boot declared type constructor that is going to be-       -- defined by this module.-       -- e.g. type instance F Int = ToBeDefined-       -- See #13803-       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)-                      $ tc_ax_branches branches-       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name-                             , co_ax_name     = tc_name-                             , co_ax_tc       = tc_tycon-                             , co_ax_role     = role-                             , co_ax_branches = manyBranches tc_branches-                             , co_ax_implicit = False }-       ; return (ACoAxiom axiom) }--tc_iface_decl _ _ (IfacePatSyn{ ifName = name-                              , ifPatMatcher = if_matcher-                              , ifPatBuilder = if_builder-                              , ifPatIsInfix = is_infix-                              , ifPatUnivBndrs = univ_bndrs-                              , ifPatExBndrs = ex_bndrs-                              , ifPatProvCtxt = prov_ctxt-                              , ifPatReqCtxt = req_ctxt-                              , ifPatArgs = args-                              , ifPatTy = pat_ty-                              , ifFieldLabels = field_labels })-  = do { traceIf (text "tc_iface_decl" <+> ppr name)-       ; matcher <- tc_pr if_matcher-       ; builder <- fmapMaybeM tc_pr if_builder-       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do-       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do-       { patsyn <- forkM (mk_doc name) $-             do { prov_theta <- tcIfaceCtxt prov_ctxt-                ; req_theta  <- tcIfaceCtxt req_ctxt-                ; pat_ty     <- tcIfaceType pat_ty-                ; arg_tys    <- mapM tcIfaceType args-                ; return $ buildPatSyn name is_infix matcher builder-                                       (univ_tvs, req_theta)-                                       (ex_tvs, prov_theta)-                                       arg_tys pat_ty field_labels }-       ; return $ AConLike . PatSynCon $ patsyn }}}-  where-     mk_doc n = text "Pattern synonym" <+> ppr n-     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)-     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)-                        ; return (id, b) }--tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)-tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1-                        ; tvs2' <- mapM tcIfaceTyVar tvs2-                        ; return (tvs1', tvs2') }--tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]-tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches--tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]-tc_ax_branch prev_branches-             (IfaceAxBranch { ifaxbTyVars = tv_bndrs-                            , ifaxbEtaTyVars = eta_tv_bndrs-                            , ifaxbCoVars = cv_bndrs-                            , ifaxbLHS = lhs, ifaxbRHS = rhs-                            , ifaxbRoles = roles, ifaxbIncomps = incomps })-  = bindIfaceTyConBinders_AT-      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->-         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom-    bindIfaceIds cv_bndrs $ \ cvs -> do-    { tc_lhs   <- tcIfaceAppArgs lhs-    ; tc_rhs   <- tcIfaceType rhs-    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return-    ; this_mod <- getIfModule-    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`-                                  moduleNameFS (moduleName this_mod))-          br = CoAxBranch { cab_loc     = loc-                          , cab_tvs     = binderVars tvs-                          , cab_eta_tvs = eta_tvs-                          , cab_cvs     = cvs-                          , cab_lhs     = tc_lhs-                          , cab_roles   = roles-                          , cab_rhs     = tc_rhs-                          , cab_incomps = map (prev_branches `getNth`) incomps }-    ; return (prev_branches ++ [br]) }--tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs-tcIfaceDataCons tycon_name tycon tc_tybinders if_cons-  = case if_cons of-        IfAbstractTyCon  -> return AbstractTyCon-        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons-                                ; return (mkDataTyConRhs data_cons) }-        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con-                                ; mkNewTyConRhs tycon_name tycon data_con }-  where-    univ_tvs :: [TyVar]-    univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)--    tag_map :: NameEnv ConTag-    tag_map = mkTyConTagMap tycon--    tc_con_decl (IfCon { ifConInfix = is_infix,-                         ifConExTCvs = ex_bndrs,-                         ifConUserTvBinders = user_bndrs,-                         ifConName = dc_name,-                         ifConCtxt = ctxt, ifConEqSpec = spec,-                         ifConArgTys = args, ifConFields = lbl_names,-                         ifConStricts = if_stricts,-                         ifConSrcStricts = if_src_stricts})-     = -- Universally-quantified tyvars are shared with-       -- parent TyCon, and are already in scope-       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do-        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)--          -- By this point, we have bound every universal and existential-          -- tyvar. Because of the dcUserTyVarBinders invariant-          -- (see Note [DataCon user type variable binders]), *every* tyvar in-          -- ifConUserTvBinders has a matching counterpart somewhere in the-          -- bound universals/existentials. As a result, calling tcIfaceTyVar-          -- below is always guaranteed to succeed.-        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->-                                   case bd of-                                     IfaceIdBndr (name, _) ->-                                       Bndr <$> tcIfaceLclId name <*> pure vis-                                     IfaceTvBndr (name, _) ->-                                       Bndr <$> tcIfaceTyVar name <*> pure vis)-                                user_bndrs--        -- Read the context and argument types, but lazily for two reasons-        -- (a) to avoid looking tugging on a recursive use of-        --     the type itself, which is knot-tied-        -- (b) to avoid faulting in the component types unless-        --     they are really needed-        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $-             do { eq_spec <- tcIfaceEqSpec spec-                ; theta   <- tcIfaceCtxt ctxt-                -- This fixes #13710.  The enclosing lazy thunk gets-                -- forced when typechecking record wildcard pattern-                -- matching (it's not completely clear why this-                -- tuple is needed), which causes trouble if one of-                -- the argument types was recursively defined.-                -- See also Note [Tying the knot]-                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")-                           $ mapM tcIfaceType args-                ; stricts <- mapM tc_strict if_stricts-                        -- The IfBang field can mention-                        -- the type itself; hence inside forkM-                ; return (eq_spec, theta, arg_tys, stricts) }--        -- Remember, tycon is the representation tycon-        ; let orig_res_ty = mkFamilyTyConApp tycon-                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))-                                             (binderVars tc_tybinders))--        ; prom_rep_name <- newTyConRepName dc_name--        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))-                       dc_name is_infix prom_rep_name-                       (map src_strict if_src_stricts)-                       (Just stricts)-                       -- Pass the HsImplBangs (i.e. final-                       -- decisions) to buildDataCon; it'll use-                       -- these to guide the construction of a-                       -- worker.-                       -- See Note [Bangs on imported data constructors] in MkId-                       lbl_names-                       univ_tvs ex_tvs user_tv_bndrs-                       eq_spec theta-                       arg_tys orig_res_ty tycon tag_map-        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)-        ; return con }-    mk_doc con_name = text "Constructor" <+> ppr con_name--    tc_strict :: IfaceBang -> IfL HsImplBang-    tc_strict IfNoBang = return (HsLazy)-    tc_strict IfStrict = return (HsStrict)-    tc_strict IfUnpack = return (HsUnpack Nothing)-    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co-                                      ; return (HsUnpack (Just co)) }--    src_strict :: IfaceSrcBang -> HsSrcBang-    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang--tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]-tcIfaceEqSpec spec-  = mapM do_item spec-  where-    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ-                              ; ty <- tcIfaceType if_ty-                              ; return (mkEqSpec tv ty) }--{--Note [Synonym kind loop]-~~~~~~~~~~~~~~~~~~~~~~~~-Notice that we eagerly grab the *kind* from the interface file, but-build a forkM thunk for the *rhs* (and family stuff).  To see why,-consider this (#2412)--M.hs:       module M where { import X; data T = MkT S }-X.hs:       module X where { import {-# SOURCE #-} M; type S = T }-M.hs-boot:  module M where { data T }--When kind-checking M.hs we need S's kind.  But we do not want to-find S's kind from (typeKind S-rhs), because we don't want to look at-S-rhs yet!  Since S is imported from X.hi, S gets just one chance to-be defined, and we must not do that until we've finished with M.T.--Solution: record S's kind in the interface file; now we can safely-look at it.--************************************************************************-*                                                                      *-                Instances-*                                                                      *-************************************************************************--}--tcIfaceInst :: IfaceClsInst -> IfL ClsInst-tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag-                          , ifInstCls = cls, ifInstTys = mb_tcs-                          , ifInstOrph = orph })-  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $-                    fmap tyThingId (tcIfaceImplicit dfun_name)-       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs-       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }--tcIfaceFamInst :: IfaceFamInst -> IfL FamInst-tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs-                             , ifFamInstAxiom = axiom_name } )-    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $-                     tcIfaceCoAxiom axiom_name-             -- will panic if branched, but that's OK-         ; let axiom'' = toUnbranchedAxiom axiom'-               mb_tcs' = map (fmap ifaceTyConName) mb_tcs-         ; return (mkImportedFamInst fam mb_tcs' axiom'') }--{--************************************************************************-*                                                                      *-                Rules-*                                                                      *-************************************************************************--We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars-are in the type environment.  However, remember that typechecking a Rule may-(as a side effect) augment the type envt, and so we may need to iterate the process.--}--tcIfaceRules :: Bool            -- True <=> ignore rules-             -> [IfaceRule]-             -> IfL [CoreRule]-tcIfaceRules ignore_prags if_rules-  | ignore_prags = return []-  | otherwise    = mapM tcIfaceRule if_rules--tcIfaceRule :: IfaceRule -> IfL CoreRule-tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,-                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,-                        ifRuleAuto = auto, ifRuleOrph = orph })-  = do  { ~(bndrs', args', rhs') <--                -- Typecheck the payload lazily, in the hope it'll never be looked at-                forkM (text "Rule" <+> pprRuleName name) $-                bindIfaceBndrs bndrs                      $ \ bndrs' ->-                do { args' <- mapM tcIfaceExpr args-                   ; rhs'  <- tcIfaceExpr rhs-                   ; return (bndrs', args', rhs') }-        ; let mb_tcs = map ifTopFreeName args-        ; this_mod <- getIfModule-        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,-                          ru_bndrs = bndrs', ru_args = args',-                          ru_rhs = occurAnalyseExpr rhs',-                          ru_rough = mb_tcs,-                          ru_origin = this_mod,-                          ru_orphan = orph,-                          ru_auto = auto,-                          ru_local = False }) } -- An imported RULE is never for a local Id-                                                -- or, even if it is (module loop, perhaps)-                                                -- we'll just leave it in the non-local set-  where-        -- This function *must* mirror exactly what Rules.roughTopNames does-        -- We could have stored the ru_rough field in the iface file-        -- but that would be redundant, I think.-        -- The only wrinkle is that we must not be deceived by-        -- type synonyms at the top of a type arg.  Since-        -- we can't tell at this point, we are careful not-        -- to write them out in coreRuleToIfaceRule-    ifTopFreeName :: IfaceExpr -> Maybe Name-    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)-    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))-    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f-    ifTopFreeName (IfaceExt n)                      = Just n-    ifTopFreeName _                                 = Nothing--{--************************************************************************-*                                                                      *-                Annotations-*                                                                      *-************************************************************************--}--tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]-tcIfaceAnnotations = mapM tcIfaceAnnotation--tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation-tcIfaceAnnotation (IfaceAnnotation target serialized) = do-    target' <- tcIfaceAnnTarget target-    return $ Annotation {-        ann_target = target',-        ann_value = serialized-    }--tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)-tcIfaceAnnTarget (NamedTarget occ) = do-    name <- lookupIfaceTop occ-    return $ NamedTarget name-tcIfaceAnnTarget (ModuleTarget mod) = do-    return $ ModuleTarget mod--{--************************************************************************-*                                                                      *-                Complete Match Pragmas-*                                                                      *-************************************************************************--}--tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]-tcIfaceCompleteSigs = mapM tcIfaceCompleteSig--tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch-tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)--{--************************************************************************-*                                                                      *-                        Types-*                                                                      *-************************************************************************--}--tcIfaceType :: IfaceType -> IfL Type-tcIfaceType = go-  where-    go (IfaceTyVar n)          = TyVarTy <$> tcIfaceTyVar n-    go (IfaceFreeTyVar n)      = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)-    go (IfaceLitTy l)          = LitTy <$> tcIfaceTyLit l-    go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2-    go (IfaceTupleTy s i tks)  = tcIfaceTupleTy s i tks-    go (IfaceAppTy t ts)-      = do { t'  <- go t-           ; ts' <- traverse go (appArgsIfaceTypes ts)-           ; pure (foldl' AppTy t' ts') }-    go (IfaceTyConApp tc tks)-      = do { tc' <- tcIfaceTyCon tc-           ; tks' <- mapM go (appArgsIfaceTypes tks)-           ; return (mkTyConApp tc' tks') }-    go (IfaceForAllTy bndr t)-      = bindIfaceForAllBndr bndr $ \ tv' vis ->-        ForAllTy (Bndr tv' vis) <$> go t-    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co-    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co--tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type-tcIfaceTupleTy sort is_promoted args- = do { args' <- tcIfaceAppArgs args-      ; let arity = length args'-      ; base_tc <- tcTupleTyCon True sort arity-      ; case is_promoted of-          NotPromoted-            -> return (mkTyConApp base_tc args')--          IsPromoted-            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)-                        kind_args = map typeKind args'-                  ; return (mkTyConApp tc (kind_args ++ args')) } }---- See Note [Unboxed tuple RuntimeRep vars] in TyCon-tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)-             -> TupleSort-             -> Arity   -- the number of args. *not* the tuple arity.-             -> IfL TyCon-tcTupleTyCon in_type sort arity-  = case sort of-      ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)-                            ; return (tyThingTyCon thing) }-      BoxedTuple   -> return (tupleTyCon Boxed   arity)-      UnboxedTuple -> return (tupleTyCon Unboxed arity')-        where arity' | in_type   = arity `div` 2-                     | otherwise = arity-                      -- in expressions, we only have term args--tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]-tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes--------------------------------------------tcIfaceCtxt :: IfaceContext -> IfL ThetaType-tcIfaceCtxt sts = mapM tcIfaceType sts--------------------------------------------tcIfaceTyLit :: IfaceTyLit -> IfL TyLit-tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)-tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)--{--%************************************************************************-%*                                                                      *-                        Coercions-*                                                                      *-************************************************************************--}--tcIfaceCo :: IfaceCoercion -> IfL Coercion-tcIfaceCo = go-  where-    go_mco IfaceMRefl    = pure MRefl-    go_mco (IfaceMCo co) = MCo <$> (go co)--    go (IfaceReflCo t)           = Refl <$> tcIfaceType t-    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco-    go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2-    go (IfaceTyConAppCo r tc cs)-      = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs-    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2-    go (IfaceForAllCo tv k c)  = do { k' <- go k-                                      ; bindIfaceBndr tv $ \ tv' ->-                                        ForAllCo tv' k' <$> go c }-    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n-    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs-    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r-                                          <*> tcIfaceType t1 <*> tcIfaceType t2-    go (IfaceSymCo c)            = SymCo    <$> go c-    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1-                                            <*> go c2-    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1-                                            <*> go t2-    go (IfaceNthCo d c)          = do { c' <- go c-                                      ; return $ mkNthCo (nthCoRole d c') d c' }-    go (IfaceLRCo lr c)          = LRCo lr  <$> go c-    go (IfaceKindCo c)           = KindCo   <$> go c-    go (IfaceSubCo c)            = SubCo    <$> go c-    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax-                                               <*> mapM go cos-    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)-    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)--    go_var :: FastString -> IfL CoVar-    go_var = tcIfaceLclId--tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance-tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv-tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco-tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco-tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str--{--************************************************************************-*                                                                      *-                        Core-*                                                                      *-************************************************************************--}--tcIfaceExpr :: IfaceExpr -> IfL CoreExpr-tcIfaceExpr (IfaceType ty)-  = Type <$> tcIfaceType ty--tcIfaceExpr (IfaceCo co)-  = Coercion <$> tcIfaceCo co--tcIfaceExpr (IfaceCast expr co)-  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co--tcIfaceExpr (IfaceLcl name)-  = Var <$> tcIfaceLclId name--tcIfaceExpr (IfaceExt gbl)-  = Var <$> tcIfaceExtId gbl--tcIfaceExpr (IfaceLit lit)-  = do lit' <- tcIfaceLit lit-       return (Lit lit')--tcIfaceExpr (IfaceFCall cc ty) = do-    ty' <- tcIfaceType ty-    u <- newUnique-    dflags <- getDynFlags-    return (Var (mkFCallId dflags u cc ty'))--tcIfaceExpr (IfaceTuple sort args)-  = do { args' <- mapM tcIfaceExpr args-       ; tc <- tcTupleTyCon False sort arity-       ; let con_tys = map exprType args'-             some_con_args = map Type con_tys ++ args'-             con_args = case sort of-               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args-               _            -> some_con_args-                        -- Put the missing type arguments back in-             con_id   = dataConWorkId (tyConSingleDataCon tc)-       ; return (mkApps (Var con_id) con_args) }-  where-    arity = length args--tcIfaceExpr (IfaceLam (bndr, os) body)-  = bindIfaceBndr bndr $ \bndr' ->-    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body-  where-    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b-    tcIfaceOneShot _            b = b--tcIfaceExpr (IfaceApp fun arg)-  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg--tcIfaceExpr (IfaceECase scrut ty)-  = do { scrut' <- tcIfaceExpr scrut-       ; ty' <- tcIfaceType ty-       ; return (castBottomExpr scrut' ty') }--tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do-    scrut' <- tcIfaceExpr scrut-    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)-    let-        scrut_ty   = exprType scrut'-        case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty-     -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors-     -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.-        tc_app     = splitTyConApp scrut_ty-                -- NB: Won't always succeed (polymorphic case)-                --     but won't be demanded in those cases-                -- NB: not tcSplitTyConApp; we are looking at Core here-                --     look through non-rec newtypes to find the tycon that-                --     corresponds to the datacon in this case alternative--    extendIfaceIdEnv [case_bndr'] $ do-     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts-     return (Case scrut' case_bndr' (coreAltsType alts') alts')--tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)-  = do  { name    <- newIfaceName (mkVarOccFS fs)-        ; ty'     <- tcIfaceType ty-        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}-                              NotTopLevel name ty' info-        ; let id = mkLocalIdWithInfo name ty' id_info-                     `asJoinId_maybe` tcJoinInfo ji-        ; rhs' <- tcIfaceExpr rhs-        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)-        ; return (Let (NonRec id rhs') body') }--tcIfaceExpr (IfaceLet (IfaceRec pairs) body)-  = do { ids <- mapM tc_rec_bndr (map fst pairs)-       ; extendIfaceIdEnv ids $ do-       { pairs' <- zipWithM tc_pair pairs ids-       ; body' <- tcIfaceExpr body-       ; return (Let (Rec pairs') body') } }- where-   tc_rec_bndr (IfLetBndr fs ty _ ji)-     = do { name <- newIfaceName (mkVarOccFS fs)-          ; ty'  <- tcIfaceType ty-          ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }-   tc_pair (IfLetBndr _ _ info _, rhs) id-     = do { rhs' <- tcIfaceExpr rhs-          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}-                                NotTopLevel (idName id) (idType id) info-          ; return (setIdInfo id id_info, rhs') }--tcIfaceExpr (IfaceTick tickish expr) = do-    expr' <- tcIfaceExpr expr-    -- If debug flag is not set: Ignore source notes-    dbgLvl <- fmap debugLevel getDynFlags-    case tickish of-      IfaceSource{} | dbgLvl == 0-                    -> return expr'-      _otherwise    -> do-        tickish' <- tcIfaceTickish tickish-        return (Tick tickish' expr')----------------------------tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)-tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)-tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)-tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)----------------------------tcIfaceLit :: Literal -> IfL Literal--- Integer literals deserialise to (LitInteger i <error thunk>)--- so tcIfaceLit just fills in the type.--- See Note [Integer literals] in Literal-tcIfaceLit (LitNumber LitNumInteger i _)-  = do t <- tcIfaceTyConByName integerTyConName-       return (mkLitInteger i (mkTyConTy t))--- Natural literals deserialise to (LitNatural i <error thunk>)--- so tcIfaceLit just fills in the type.--- See Note [Natural literals] in Literal-tcIfaceLit (LitNumber LitNumNatural i _)-  = do t <- tcIfaceTyConByName naturalTyConName-       return (mkLitNatural i (mkTyConTy t))-tcIfaceLit lit = return lit----------------------------tcIfaceAlt :: CoreExpr -> (TyCon, [Type])-           -> (IfaceConAlt, [FastString], IfaceExpr)-           -> IfL (AltCon, [TyVar], CoreExpr)-tcIfaceAlt _ _ (IfaceDefault, names, rhs)-  = ASSERT( null names ) do-    rhs' <- tcIfaceExpr rhs-    return (DEFAULT, [], rhs')--tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)-  = ASSERT( null names ) do-    lit' <- tcIfaceLit lit-    rhs' <- tcIfaceExpr rhs-    return (LitAlt lit', [], rhs')---- A case alternative is made quite a bit more complicated--- by the fact that we omit type annotations because we can--- work them out.  True enough, but its not that easy!-tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)-  = do  { con <- tcIfaceDataCon data_occ-        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))-               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))-        ; tcIfaceDataAlt con inst_tys arg_strs rhs }--tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr-               -> IfL (AltCon, [TyVar], CoreExpr)-tcIfaceDataAlt con inst_tys arg_strs rhs-  = do  { us <- newUniqueSupply-        ; let uniqs = uniqsFromSupply us-        ; let (ex_tvs, arg_ids)-                      = dataConRepFSInstPat arg_strs uniqs con inst_tys--        ; rhs' <- extendIfaceEnvs  ex_tvs       $-                  extendIfaceIdEnv arg_ids      $-                  tcIfaceExpr rhs-        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }--{--************************************************************************-*                                                                      *-                IdInfo-*                                                                      *-************************************************************************--}--tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails-tcIdDetails _  IfVanillaId = return VanillaId-tcIdDetails ty IfDFunId-  = return (DFunId (isNewTyCon (classTyCon cls)))-  where-    (_, _, cls, _) = tcSplitDFunTy ty--tcIdDetails _ (IfRecSelId tc naughty)-  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)-                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)-                       tc-       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }-  where-    tyThingPatSyn (AConLike (PatSynCon ps)) = ps-    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"--tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo-tcIdInfo ignore_prags toplvl name ty info = do-    lcl_env <- getLclEnv-    -- Set the CgInfo to something sensible but uninformative before-    -- we start; default assumption is that it has CAFs-    let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding-                  | otherwise       = vanillaIdInfo-    if ignore_prags-        then return init_info-        else case info of-                NoInfo -> return init_info-                HasInfo info -> foldlM tcPrag init_info info-  where-    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo-    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)-    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)-    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)-    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)-    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)--        -- The next two are lazy, so they don't transitively suck stuff in-    tcPrag info (HsUnfold lb if_unf)-      = do { unf <- tcUnfolding toplvl name ty info if_unf-           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker-                       | otherwise = info-           ; return (info1 `setUnfoldingInfo` unf) }--tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity-tcJoinInfo (IfaceJoinPoint ar) = Just ar-tcJoinInfo IfaceNotJoinPoint   = Nothing--tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding-tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)-  = do  { dflags <- getDynFlags-        ; mb_expr <- tcPragExpr toplvl name if_expr-        ; let unf_src | stable    = InlineStable-                      | otherwise = InlineRhs-        ; return $ case mb_expr of-            Nothing -> NoUnfolding-            Just expr -> mkUnfolding dflags unf_src-                           True {- Top level -}-                           (isBottomingSig strict_sig)-                           expr-        }-  where-     -- Strictness should occur before unfolding!-    strict_sig = strictnessInfo info-tcUnfolding toplvl name _ _ (IfCompulsory if_expr)-  = do  { mb_expr <- tcPragExpr toplvl name if_expr-        ; return (case mb_expr of-                    Nothing   -> NoUnfolding-                    Just expr -> mkCompulsoryUnfolding expr) }--tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)-  = do  { mb_expr <- tcPragExpr toplvl name if_expr-        ; return (case mb_expr of-                    Nothing   -> NoUnfolding-                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}-  where-    guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }--tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)-  = bindIfaceBndrs bs $ \ bs' ->-    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops-       ; return (case mb_ops1 of-                    Nothing   -> noUnfolding-                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }-  where-    doc = text "Class ops for dfun" <+> ppr name-    (_, _, cls, _) = tcSplitDFunTy dfun_ty--{--For unfoldings we try to do the job lazily, so that we never type check-an unfolding that isn't going to be looked at.--}--tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)-tcPragExpr toplvl name expr-  = forkM_maybe doc $ do-    core_expr' <- tcIfaceExpr expr--    -- Check for type consistency in the unfolding-    -- See Note [Linting Unfoldings from Interfaces]-    when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do-        in_scope <- get_in_scope-        dflags   <- getDynFlags-        case lintUnfolding dflags noSrcLoc in_scope core_expr' of-          Nothing       -> return ()-          Just fail_msg -> do { mod <- getIfModule-                              ; pprPanic "Iface Lint failure"-                                  (vcat [ text "In interface for" <+> ppr mod-                                        , hang doc 2 fail_msg-                                        , ppr name <+> equals <+> ppr core_expr'-                                        , text "Iface expr =" <+> ppr expr ]) }-    return core_expr'-  where-    doc = text "Unfolding of" <+> ppr name--    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting-    get_in_scope-        = do { (gbl_env, lcl_env) <- getEnvs-             ; rec_ids <- case if_rec_types gbl_env of-                            Nothing -> return []-                            Just (_, get_env) -> do-                               { type_env <- setLclEnv () get_env-                               ; return (typeEnvIds type_env) }-             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`-                       bindingsVars (if_id_env lcl_env) `unionVarSet`-                       mkVarSet rec_ids) }--    bindingsVars :: FastStringEnv Var -> VarSet-    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm-      -- It's OK to use nonDetEltsUFM here because we immediately forget-      -- the ordering by creating a set--{--************************************************************************-*                                                                      *-                Getting from Names to TyThings-*                                                                      *-************************************************************************--}--tcIfaceGlobal :: Name -> IfL TyThing-tcIfaceGlobal name-  | Just thing <- wiredInNameTyThing_maybe name-        -- Wired-in things include TyCons, DataCons, and Ids-        -- Even though we are in an interface file, we want to make-        -- sure the instances and RULES of this thing (particularly TyCon) are loaded-        -- Imagine: f :: Double -> Double-  = do { ifCheckWiredInThing thing; return thing }--  | otherwise-  = do  { env <- getGblEnv-        ; case if_rec_types env of {    -- Note [Tying the knot]-            Just (mod, get_type_env)-                | nameIsLocalOrFrom mod name-                -> do           -- It's defined in the module being compiled-                { type_env <- setLclEnv () get_type_env         -- yuk-                ; case lookupNameEnv type_env name of-                    Just thing -> return thing-                    -- See Note [Knot-tying fallback on boot]-                    Nothing   -> via_external-                }--          ; _ -> via_external }}-  where-    via_external =  do-        { hsc_env <- getTopEnv-        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)-        ; case mb_thing of {-            Just thing -> return thing ;-            Nothing    -> do--        { mb_thing <- importDecl name   -- It's imported; go get it-        ; case mb_thing of-            Failed err      -> failIfM err-            Succeeded thing -> return thing-        }}}---- Note [Tying the knot]--- ~~~~~~~~~~~~~~~~~~~~~--- The if_rec_types field is used when we are compiling M.hs, which indirectly--- imports Foo.hi, which mentions M.T Then we look up M.T in M's type--- environment, which is splatted into if_rec_types after we've built M's type--- envt.------ This is a dark and complicated part of GHC type checking, with a lot--- of moving parts.  Interested readers should also look at:------      * Note [Knot-tying typecheckIface]---      * Note [DFun knot-tying]---      * Note [hsc_type_env_var hack]---      * Note [Knot-tying fallback on boot]------ There is also a wiki page on the subject, see:------      https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot---- Note [Knot-tying fallback on boot]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Suppose that you are typechecking A.hs, which transitively imports,--- via B.hs, A.hs-boot. When we poke on B.hs and discover that it--- has a reference to a type T from A, what TyThing should we wire--- it up with? Clearly, if we have already typechecked T and--- added it into the type environment, we should go ahead and use that--- type. But what if we haven't typechecked it yet?------ For the longest time, GHC adopted the policy that this was--- *an error condition*; that you MUST NEVER poke on B.hs's reference--- to a T defined in A.hs until A.hs has gotten around to kind-checking--- T and adding it to the env. However, actually ensuring this is the--- case has proven to be a bug farm, because it's really difficult to--- actually ensure this never happens. The problem was especially poignant--- with type family consistency checks, which eagerly happen before any--- typechecking takes place.------ Today, we take a different strategy: if we ever try to access--- an entity from A which doesn't exist, we just fall back on the--- definition of A from the hs-boot file. This is complicated in--- its own way: it means that you may end up with a mix of A.hs and--- A.hs-boot TyThings during the course of typechecking.  We don't--- think (and have not observed) any cases where this would cause--- problems, but the hypothetical situation one might worry about--- is something along these lines in Core:------    case x of---        A -> e1---        B -> e2------ If, when typechecking this, we find x :: T, and the T we are hooked--- up with is the abstract one from the hs-boot file, rather than the--- one defined in this module with constructors A and B.  But it's hard--- to see how this could happen, especially because the reference to--- the constructor (A and B) means that GHC will always typecheck--- this expression *after* typechecking T.--tcIfaceTyConByName :: IfExtName -> IfL TyCon-tcIfaceTyConByName name-  = do { thing <- tcIfaceGlobal name-       ; return (tyThingTyCon thing) }--tcIfaceTyCon :: IfaceTyCon -> IfL TyCon-tcIfaceTyCon (IfaceTyCon name info)-  = do { thing <- tcIfaceGlobal name-       ; return $ case ifaceTyConIsPromoted info of-           NotPromoted -> tyThingTyCon thing-           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }--tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)-tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name-                         ; return (tyThingCoAxiom thing) }---tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule--- Unlike CoAxioms, which arise form user 'type instance' declarations,--- there are a fixed set of CoAxiomRules,--- currently enumerated in typeNatCoAxiomRules-tcIfaceCoAxiomRule n-  = case Map.lookup n typeNatCoAxiomRules of-        Just ax -> return ax-        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)--tcIfaceDataCon :: Name -> IfL DataCon-tcIfaceDataCon name = do { thing <- tcIfaceGlobal name-                         ; case thing of-                                AConLike (RealDataCon dc) -> return dc-                                _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }--tcIfaceExtId :: Name -> IfL Id-tcIfaceExtId name = do { thing <- tcIfaceGlobal name-                       ; case thing of-                          AnId id -> return id-                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }---- See Note [Resolving never-exported Names in TcIface]-tcIfaceImplicit :: Name -> IfL TyThing-tcIfaceImplicit n = do-    lcl_env <- getLclEnv-    case if_implicits_env lcl_env of-        Nothing -> tcIfaceGlobal n-        Just tenv ->-            case lookupTypeEnv tenv n of-                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)-                Just tything -> return tything--{--************************************************************************-*                                                                      *-                Bindings-*                                                                      *-************************************************************************--}--bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a-bindIfaceId (fs, ty) thing_inside-  = do  { name <- newIfaceName (mkVarOccFS fs)-        ; ty' <- tcIfaceType ty-        ; let id = mkLocalIdOrCoVar name ty'-          -- We should not have "OrCoVar" here, this is a bug (#17545)-        ; extendIfaceIdEnv [id] (thing_inside id) }--bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a-bindIfaceIds [] thing_inside = thing_inside []-bindIfaceIds (b:bs) thing_inside-  = bindIfaceId b   $ \b'  ->-    bindIfaceIds bs $ \bs' ->-    thing_inside (b':bs')--bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a-bindIfaceBndr (IfaceIdBndr bndr) thing_inside-  = bindIfaceId bndr thing_inside-bindIfaceBndr (IfaceTvBndr bndr) thing_inside-  = bindIfaceTyVar bndr thing_inside--bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a-bindIfaceBndrs []     thing_inside = thing_inside []-bindIfaceBndrs (b:bs) thing_inside-  = bindIfaceBndr b     $ \ b' ->-    bindIfaceBndrs bs   $ \ bs' ->-    thing_inside (b':bs')--------------------------bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a-bindIfaceForAllBndrs [] thing_inside = thing_inside []-bindIfaceForAllBndrs (bndr:bndrs) thing_inside-  = bindIfaceForAllBndr bndr $ \tv vis ->-    bindIfaceForAllBndrs bndrs $ \bndrs' ->-    thing_inside (mkTyCoVarBinder vis tv : bndrs')--bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a-bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside-  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis-bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside-  = bindIfaceId tv $ \tv' -> thing_inside tv' vis--bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a-bindIfaceTyVar (occ,kind) thing_inside-  = do  { name <- newIfaceName (mkTyVarOccFS occ)-        ; tyvar <- mk_iface_tyvar name kind-        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }--bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a-bindIfaceTyVars [] thing_inside = thing_inside []-bindIfaceTyVars (bndr:bndrs) thing_inside-  = bindIfaceTyVar bndr   $ \tv  ->-    bindIfaceTyVars bndrs $ \tvs ->-    thing_inside (tv : tvs)--mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar-mk_iface_tyvar name ifKind-   = do { kind <- tcIfaceType ifKind-        ; return (Var.mkTyVar name kind) }--bindIfaceTyConBinders :: [IfaceTyConBinder]-                      -> ([TyConBinder] -> IfL a) -> IfL a-bindIfaceTyConBinders [] thing_inside = thing_inside []-bindIfaceTyConBinders (b:bs) thing_inside-  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->-    bindIfaceTyConBinders bs              $ \ bs' ->-    thing_inside (b':bs')--bindIfaceTyConBinders_AT :: [IfaceTyConBinder]-                         -> ([TyConBinder] -> IfL a) -> IfL a--- Used for type variable in nested associated data/type declarations--- where some of the type variables are already in scope---    class C a where { data T a b }--- Here 'a' is in scope when we look at the 'data T'-bindIfaceTyConBinders_AT [] thing_inside-  = thing_inside []-bindIfaceTyConBinders_AT (b : bs) thing_inside-  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->-    bindIfaceTyConBinders_AT      bs $ \bs' ->-    thing_inside (b':bs')-  where-    bind_tv tv thing-      = do { mb_tv <- lookupIfaceVar tv-           ; case mb_tv of-               Just b' -> thing b'-               Nothing -> bindIfaceBndr tv thing }--bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)-                      -> IfaceTyConBinder-                      -> (TyConBinder -> IfL a) -> IfL a-bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside-  = bind_tv tv $ \tv' ->-    thing_inside (Bndr tv' vis)
− compiler/iface/TcIface.hs-boot 
@@ -1,19 +0,0 @@-module TcIface where--import GhcPrelude-import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,-                     IfaceAnnotation, IfaceCompleteMatch )-import TyCoRep     ( TyThing )-import TcRnTypes   ( IfL )-import InstEnv     ( ClsInst )-import FamInstEnv  ( FamInst )-import CoreSyn     ( CoreRule )-import HscTypes    ( CompleteMatch )-import Annotations ( Annotation )--tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing-tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]-tcIfaceInst         :: IfaceClsInst -> IfL ClsInst-tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst-tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]-tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
compiler/llvmGen/Llvm/Types.hs view
@@ -566,7 +566,7 @@   ppr OptSize            = text "optsize"   ppr NoReturn           = text "noreturn"   ppr NoUnwind           = text "nounwind"-  ppr ReadNone           = text "readnon"+  ppr ReadNone           = text "readnone"   ppr ReadOnly           = text "readonly"   ppr Ssp                = text "ssp"   ppr SspReq             = text "ssqreq"
compiler/llvmGen/LlvmCodeGen.hs view
@@ -18,9 +18,9 @@ import LlvmMangler  import GHC.StgToCmm.CgUtils ( fixStgRegisters )-import Cmm-import Hoopl.Collections-import PprCmm+import GHC.Cmm+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Ppr  import BufWrite import DynFlags
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- ---------------------------------------------------------------------------- -- | Base LLVM Code Generation module --@@ -28,7 +30,7 @@          cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,         llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,-        llvmPtrBits, tysToParams, llvmFunSection,+        llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,          strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,         getGlobalPtr, generateExternDecls,@@ -44,11 +46,12 @@ import Llvm import LlvmCodeGen.Regs -import CLabel+import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs ) import DynFlags import FastString-import Cmm              hiding ( succ )+import GHC.Cmm              hiding ( succ )+import GHC.Cmm.Utils (regsOverlap) import Outputable as Outp import GHC.Platform import UniqFM@@ -62,7 +65,7 @@ import Data.Maybe (fromJust) import Control.Monad (ap) import Data.Char (isDigit)-import Data.List (intercalate)+import Data.List (sort, groupBy, intercalate) import qualified Data.List.NonEmpty as NE  -- ----------------------------------------------------------------------------@@ -152,17 +155,110 @@ -- | A Function's arguments llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] llvmFunArgs dflags live =-    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))+    map (lmGlobalRegArg dflags) (filter isPassed allRegs)     where platform = targetPlatform dflags-          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live-          isPassed r = not (isSSE r) || isLive r-          isSSE (FloatReg _)  = True-          isSSE (DoubleReg _) = True-          isSSE (XmmReg _)    = True-          isSSE (YmmReg _)    = True-          isSSE (ZmmReg _)    = True-          isSSE _             = False+          allRegs = activeStgRegs platform+          paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live+          isLive r = r `elem` alwaysLive || r `elem` paddedLive+          isPassed r = not (isFPR r) || isLive r ++isFPR :: GlobalReg -> Bool+isFPR (FloatReg _)  = True+isFPR (DoubleReg _) = True+isFPR (XmmReg _)    = True+isFPR (YmmReg _)    = True+isFPR (ZmmReg _)    = True+isFPR _             = False++sameFPRClass :: GlobalReg -> GlobalReg -> Bool+sameFPRClass (FloatReg _)  (FloatReg _) = True+sameFPRClass (DoubleReg _) (DoubleReg _) = True+sameFPRClass (XmmReg _)    (XmmReg _) = True+sameFPRClass (YmmReg _)    (YmmReg _) = True+sameFPRClass (ZmmReg _)    (ZmmReg _) = True+sameFPRClass _             _          = False++normalizeFPRNum :: GlobalReg -> GlobalReg+normalizeFPRNum (FloatReg _)  = FloatReg 1+normalizeFPRNum (DoubleReg _) = DoubleReg 1+normalizeFPRNum (XmmReg _)    = XmmReg 1+normalizeFPRNum (YmmReg _)    = YmmReg 1+normalizeFPRNum (ZmmReg _)    = ZmmReg 1+normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"++getFPRCtor :: GlobalReg -> Int -> GlobalReg+getFPRCtor (FloatReg _)  = FloatReg+getFPRCtor (DoubleReg _) = DoubleReg+getFPRCtor (XmmReg _)    = XmmReg+getFPRCtor (YmmReg _)    = YmmReg+getFPRCtor (ZmmReg _)    = ZmmReg+getFPRCtor _ = error "getFPRCtor expected only FPR regs"++fprRegNum :: GlobalReg -> Int+fprRegNum (FloatReg i)  = i+fprRegNum (DoubleReg i) = i+fprRegNum (XmmReg i)    = i+fprRegNum (YmmReg i)    = i+fprRegNum (ZmmReg i)    = i+fprRegNum _ = error "fprRegNum expected only FPR regs"++-- | Input: dynflags, and the list of live registers+--+-- Output: An augmented list of live registers, where padding was+-- added to the list of registers to ensure the calling convention is+-- correctly used by LLVM.+--+-- Each global reg in the returned list is tagged with a bool, which+-- indicates whether the global reg was added as padding, or was an original+-- live register.+--+-- That is, True => padding, False => a real, live global register.+--+-- Also, the returned list is not sorted in any particular order.+--+padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]+padLiveArgs dflags live =+      if platformUnregisterised plat+        then taggedLive -- not using GHC's register convention for platform.+        else padding ++ taggedLive+  where+    taggedLive = map (\x -> (False, x)) live+    plat = targetPlatform dflags++    fprLive = filter isFPR live+    padding = concatMap calcPad $ groupBy sharesClass fprLive++    sharesClass :: GlobalReg -> GlobalReg -> Bool+    sharesClass a b = sameFPRClass a b || overlappingClass+      where+        overlappingClass = regsOverlap dflags (norm a) (norm b)+        norm = CmmGlobal . normalizeFPRNum++    calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]+    calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs++getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]+getFPRPadding paddingCtor live = padding+    where+        fprRegNums = sort $ map fprRegNum live+        (_, padding) = foldl assignSlots (1, []) $ fprRegNums++        assignSlots (i, acc) regNum+            | i == regNum = -- don't need padding here+                  (i+1, acc)+            | i < regNum = let -- add padding for slots i .. regNum-1+                  numNeeded = regNum-i+                  acc' = genPad i numNeeded ++ acc+                in+                  (regNum+1, acc')+            | otherwise = error "padLiveArgs -- i > regNum ??"++        genPad start n =+            take n $ flip map (iterate (+1) start) (\i ->+                (True, paddingCtor i))++ -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] llvmStdFunAttrs = [NoUnwind]@@ -582,7 +678,7 @@ -- point of definition instead of the point of usage, as was previously -- done. See #9142 for details. ----- Finally, case (1) is trival. As we already have a definition for+-- Finally, case (1) is trivial. As we already have a definition for -- and therefore know the type of the referenced symbol, we can do -- away with casting the alias to the desired type in @getSymbolPtr@ -- and instead just emit a reference to the definition symbol directly.
compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, GADTs #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmProc to LLVM code. --@@ -13,16 +14,16 @@ import LlvmCodeGen.Base import LlvmCodeGen.Regs -import BlockId-import GHC.Platform.Regs ( activeStgRegs, callerSaves )-import CLabel-import Cmm-import PprCmm-import CmmUtils-import CmmSwitch-import Hoopl.Block-import Hoopl.Graph-import Hoopl.Collections+import GHC.Cmm.BlockId+import GHC.Platform.Regs ( activeStgRegs )+import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Cmm.Ppr as PprCmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Collections  import DynFlags import FastString@@ -222,7 +223,6 @@     fptr    <- liftExprData $ getFunPtr funTy t     argVars' <- castVarsW Signed $ zip argVars argTy -    doTrashStmts     let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]     statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []   | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)@@ -307,7 +307,6 @@     fptr          <- getFunPtrW funTy t     argVars' <- castVarsW Signed $ zip argVars argTy -    doTrashStmts     let alignVal = mkIntLit i32 align         arguments = argVars' ++ (alignVal:isVolVal)     statement $ Expr $ Call StdCall fptr arguments []@@ -462,7 +461,6 @@                  | never_returns     = statement $ Unreachable                  | otherwise         = return () -    doTrashStmts      -- make the actual call     case retTy of@@ -1798,7 +1796,7 @@  -- | Find CmmRegs that get assigned and allocate them on the stack ----- Any register that gets written needs to be allcoated on the+-- Any register that gets written needs to be allocated on the -- stack. This avoids having to map a CmmReg to an equivalent SSA form -- and avoids having to deal with Phi node insertion.  This is also -- the approach recommended by LLVM developers.@@ -1810,12 +1808,9 @@ funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData funPrologue live cmmBlocks = do -  trash <- getTrashRegs   let getAssignedRegs :: CmmNode O O -> [CmmReg]       getAssignedRegs (CmmAssign reg _)  = [reg]-      -- Calls will trash all registers. Unfortunately, this needs them to-      -- be stack-allocated in the first place.-      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs       getAssignedRegs _                  = []       getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body       assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks@@ -1847,19 +1842,14 @@ -- STG Liveness optimisation done here. funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do+    dflags <- getDynFlags -    -- Have information and liveness optimisation is enabled?-    let liveRegs = alwaysLive ++ live-        isSSE (FloatReg _)  = True-        isSSE (DoubleReg _) = True-        isSSE (XmmReg _)    = True-        isSSE (YmmReg _)    = True-        isSSE (ZmmReg _)    = True-        isSSE _             = False+    -- the bool indicates whether the register is padding.+    let alwaysNeeded = map (\r -> (False, r)) alwaysLive+        livePadded = alwaysNeeded ++ padLiveArgs dflags live      -- Set to value or "undef" depending on whether the register is     -- actually live-    dflags <- getDynFlags     let loadExpr r = do           (v, _, s) <- getCmmRegVal (CmmGlobal r)           return (Just $ v, s)@@ -1867,39 +1857,17 @@           let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)           return (Just $ LMLitVar $ LMUndefLit ty, nilOL)     platform <- getDynFlag targetPlatform-    loads <- flip mapM (activeStgRegs platform) $ \r -> case () of-      _ | r `elem` liveRegs  -> loadExpr r-        | not (isSSE r)      -> loadUndef r+    let allRegs = activeStgRegs platform+    loads <- flip mapM allRegs $ \r -> case () of+      _ | (False, r) `elem` livePadded+                             -> loadExpr r   -- if r is not padding, load it+        | not (isFPR r) || (True, r) `elem` livePadded+                             -> loadUndef r         | otherwise          -> return (Nothing, nilOL)      let (vars, stmts) = unzip loads     return (catMaybes vars, concatOL stmts) ---- | A series of statements to trash all the STG registers.------ In LLVM we pass the STG registers around everywhere in function calls.--- So this means LLVM considers them live across the entire function, when--- in reality they usually aren't. For Caller save registers across C calls--- the saving and restoring of them is done by the Cmm code generator,--- using Cmm local vars. So to stop LLVM saving them as well (and saving--- all of them since it thinks they're always live, we trash them just--- before the call by assigning the 'undef' value to them. The ones we--- need are restored from the Cmm local var and the ones we don't need--- are fine to be trashed.-getTrashStmts :: LlvmM LlvmStatements-getTrashStmts = do-  regs <- getTrashRegs-  stmts <- flip mapM regs $ \ r -> do-    reg <- getCmmReg (CmmGlobal r)-    let ty = (pLower . getVarType) reg-    return $ Store (LMLitVar $ LMUndefLit ty) reg-  return $ toOL stmts--getTrashRegs :: LlvmM [GlobalReg]-getTrashRegs = do plat <- getLlvmPlatform-                  return $ filter (callerSaves plat) (activeStgRegs plat)- -- | Get a function pointer to the CLabel specified. -- -- This is for Haskell functions, function type is assumed, so doesn't work@@ -2020,11 +1988,6 @@  genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar genLoadW atomic e ty = liftExprData $ genLoad atomic e ty--doTrashStmts :: WriterT LlvmAccum LlvmM ()-doTrashStmts = do-    stmts <- lift getTrashStmts-    tell $ LlvmAccum stmts mempty  -- | Return element of single-element list; 'panic' if list is not a single-element list singletonPanic :: String -> [a] -> a
compiler/llvmGen/LlvmCodeGen/Data.hs view
@@ -14,9 +14,9 @@ import Llvm import LlvmCodeGen.Base -import BlockId-import CLabel-import Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm import DynFlags import GHC.Platform
compiler/llvmGen/LlvmCodeGen/Ppr.hs view
@@ -15,8 +15,8 @@ import LlvmCodeGen.Base import LlvmCodeGen.Data -import CLabel-import Cmm+import GHC.Cmm.CLabel+import GHC.Cmm  import FastString import Outputable
compiler/llvmGen/LlvmCodeGen/Regs.hs view
@@ -15,7 +15,7 @@  import Llvm -import CmmExpr+import GHC.Cmm.Expr import DynFlags import FastString import Outputable ( panic )
compiler/main/Ar.hs view
@@ -13,7 +13,7 @@ As Archives are rather simple structurally, we can just build the archives with Haskell directly and use ranlib on the final result to get the symbol index. This should allow us to work around with the differences/abailability-of libtool across differet platforms.+of libtool across different platforms. -} module Ar   (ArchiveEntry(..)
compiler/main/CodeOutput.hs view
@@ -18,10 +18,10 @@ import UniqSupply       ( mkSplitUniqSupply )  import Finder           ( mkStubPaths )-import PprC             ( writeC )-import CmmLint          ( cmmLint )+import GHC.CmmToC             ( writeC )+import GHC.Cmm.Lint          ( cmmLint ) import Packages-import Cmm              ( RawCmmGroup )+import GHC.Cmm              ( RawCmmGroup ) import HscTypes import DynFlags import Stream           ( Stream )
compiler/main/DriverMkDepend.hs view
@@ -383,7 +383,7 @@     pp_group (CyclicSCC mss)         = ASSERT( not (null boot_only) )                 -- The boot-only list must be non-empty, else there would-                -- be an infinite chain of non-boot imoprts, and we've+                -- be an infinite chain of non-boot imports, and we've                 -- already checked for that in processModDeps           pp_ms loop_breaker $$ vcat (map pp_group groups)         where
compiler/main/DriverPipeline.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ ----------------------------------------------------------------------------- -- -- GHC Driver@@ -66,7 +68,7 @@ import Ar import Bag              ( unitBag ) import FastString       ( mkFastString )-import MkIface          ( mkFullIface )+import GHC.Iface.Utils  ( mkFullIface )  import Exception import System.Directory@@ -1250,7 +1252,7 @@          -- pass -D or -optP to preprocessor when compiling foreign C files         -- (#16737). Doing it in this way is simpler and also enable the C-        -- compiler to performs preprocessing and parsing in a single pass,+        -- compiler to perform preprocessing and parsing in a single pass,         -- but it may introduce inconsistency if a different pgm_P is specified.         let more_preprocessor_opts = concat               [ ["-Xpreprocessor", i]@@ -2012,7 +2014,7 @@      -- MIN_VERSION macros     let uids = explicitPackages (pkgState dflags)-        pkgs = catMaybes (map (lookupPackage dflags) uids)+        pkgs = catMaybes (map (lookupUnit dflags) uids)     mb_macro_include <-         if not (null pkgs) && gopt Opt_VersionMacros dflags             then do macro_stub <- newTempName dflags TFL_CurrentModule "h"@@ -2072,7 +2074,7 @@ -- --------------------------------------------------------------------------- -- Macros (cribbed from Cabal) -generatePackageVersionMacros :: [PackageConfig] -> String+generatePackageVersionMacros :: [UnitInfo] -> String generatePackageVersionMacros pkgs = concat   -- Do not add any C-style comments. See #3389.   [ generateMacros "" pkgname version
compiler/main/DynamicLoading.hs view
@@ -28,12 +28,12 @@ import SrcLoc           ( noSrcSpan ) import Finder           ( findPluginModule, cannotFindModule ) import TcRnMonad        ( initTcInteractive, initIfaceTcRn )-import LoadIface        ( loadPluginInterface )+import GHC.Iface.Load   ( loadPluginInterface ) import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)                         , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName                         , gre_name, mkRdrQual ) import OccName          ( OccName, mkVarOcc )-import RnNames          ( gresFromAvails )+import GHC.Rename.Names ( gresFromAvails ) import Plugins import PrelNames        ( pluginTyConName, frontendPluginTyConName )
compiler/main/Finder.hs view
@@ -349,12 +349,12 @@ -- requires a few invariants to be upheld: (1) the 'Module' in question must -- be the module identifier of the *original* implementation of a module, -- not a reexport (this invariant is upheld by @Packages.hs@) and (2)--- the 'PackageConfig' must be consistent with the unit id in the 'Module'.+-- the 'UnitInfo' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config.-findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult+findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult findPackageModule_ hsc_env mod pkg_conf =-  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )+  ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) )   modLocationCache hsc_env mod $    -- special case for GHC.Prim; we won't find it in the filesystem.@@ -714,19 +714,19 @@          tried_these files dflags      pkg_hidden :: UnitId -> SDoc-    pkg_hidden pkgid =+    pkg_hidden uid =         text "It is a member of the hidden package"-        <+> quotes (ppr pkgid)+        <+> quotes (ppr uid)         --FIXME: we don't really want to show the unit id here we should         -- show the source package id or installed package id if it's ambiguous-        <> dot $$ pkg_hidden_hint pkgid-    pkg_hidden_hint pkgid+        <> dot $$ pkg_hidden_hint uid+    pkg_hidden_hint uid      | gopt Opt_BuildingCabalPackage dflags-        = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)+        = let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid)            in text "Perhaps you need to add" <+>               quotes (ppr (packageName pkg)) <+>               text "to the build-depends in your .cabal file."-     | Just pkg <- lookupPackage dflags pkgid+     | Just pkg <- lookupUnit dflags uid          = text "You can run" <+>            quotes (text ":set -package " <> ppr (packageName pkg)) <+>            text "to expose it." $$
compiler/main/GHC.hs view
@@ -34,6 +34,7 @@         getSessionDynFlags, setSessionDynFlags,         getProgramDynFlags, setProgramDynFlags, setLogAction,         getInteractiveDynFlags, setInteractiveDynFlags,+        interpretPackageEnv,          -- * Targets         Target(..), TargetId(..), Phase,@@ -306,7 +307,7 @@ import DriverPipeline   ( compileOne' ) import GhcMonad import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )-import LoadIface        ( loadSysInterface )+import GHC.Iface.Load   ( loadSysInterface ) import TcRnTypes import Predicate import Packages@@ -327,7 +328,7 @@ import FamInstEnv ( FamInst ) import SrcLoc import CoreSyn-import TidyPgm+import GHC.Iface.Tidy import DriverPhases     ( Phase(..), isHaskellSrcFilename ) import Finder import HscTypes@@ -346,7 +347,6 @@ import StringBuffer import Outputable import BasicTypes-import Maybes           ( expectJust ) import FastString import qualified Parser import Lexer@@ -364,7 +364,6 @@ import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Sequence as Seq-import System.Directory ( doesFileExist ) import Data.Maybe import Data.Time import Data.Typeable    ( Typeable )@@ -375,7 +374,12 @@ import Data.IORef import System.FilePath +import Maybes+import System.IO.Error  ( isDoesNotExistError )+import System.Environment ( getEnv )+import System.Directory + -- %************************************************************************ -- %*                                                                      * --             Initialisation: exception handlers@@ -588,9 +592,10 @@ setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId] setSessionDynFlags dflags = do   dflags' <- checkNewDynFlags dflags-  (dflags'', preload) <- liftIO $ initPackages dflags'-  modifySession $ \h -> h{ hsc_dflags = dflags''-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }+  dflags'' <- liftIO $ interpretPackageEnv dflags'+  (dflags''', preload) <- liftIO $ initPackages dflags''+  modifySession $ \h -> h{ hsc_dflags = dflags'''+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' } }   invalidateModSummaryCache   return preload @@ -638,7 +643,7 @@ -- that the next downsweep will think that all the files have changed -- and preprocess them again.  This won't necessarily cause everything -- to be recompiled, because by the time we check whether we need to--- recopmile a module, we'll have re-summarised the module and have a+-- recompile a module, we'll have re-summarised the module and have a -- correct ModSummary. -- invalidateModSummaryCache :: GhcMonad m => m ()@@ -857,7 +862,7 @@ instance DesugaredMod DesugaredModule where   coreModule m = dm_core_module m -type ParsedSource      = Located (HsModule GhcPs)+type ParsedSource      = Located HsModule type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],                           Maybe LHsDocString) type TypecheckedSource = LHsBinds GhcTc@@ -1306,7 +1311,7 @@                  -> m [Module] packageDbModules only_exposed = do    dflags <- getSessionDynFlags-   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))+   let pkgs = eltsUFM (unitInfoMap (pkgState dflags))    return $      [ mkModule pid modname      | p <- pkgs@@ -1335,7 +1340,7 @@ -- ToDo: check for small transformations that happen to the syntax in -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) --- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way+-- ToDo: maybe use TH syntax instead of Iface syntax?  There's already a way -- to get from TyCons, Ids etc. to TH syntax (reify).  -- :browse will use either lm_toplev or inspect lm_interface, depending@@ -1547,7 +1552,7 @@ parser :: String         -- ^ Haskell module source text (full Unicode is supported)        -> DynFlags       -- ^ the flags        -> FilePath       -- ^ the filename (for source locations)-       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))+       -> (WarningMessages, Either ErrorMessages (Located HsModule))  parser str dflags filename =    let@@ -1563,3 +1568,138 @@      POk pst rdr_module ->          let (warns,_) = getMessages pst dflags in          (warns, Right rdr_module)++-- -----------------------------------------------------------------------------+-- | Find the package environment (if one exists)+--+-- We interpret the package environment as a set of package flags; to be+-- specific, if we find a package environment file like+--+-- > clear-package-db+-- > global-package-db+-- > package-db blah/package.conf.d+-- > package-id id1+-- > package-id id2+--+-- we interpret this as+--+-- > [ -hide-all-packages+-- > , -clear-package-db+-- > , -global-package-db+-- > , -package-db blah/package.conf.d+-- > , -package-id id1+-- > , -package-id id2+-- > ]+--+-- There's also an older syntax alias for package-id, which is just an+-- unadorned package id+--+-- > id1+-- > id2+--+interpretPackageEnv :: DynFlags -> IO DynFlags+interpretPackageEnv dflags = do+    mPkgEnv <- runMaybeT $ msum $ [+                   getCmdLineArg >>= \env -> msum [+                       probeNullEnv env+                     , probeEnvFile env+                     , probeEnvName env+                     , cmdLineError env+                     ]+                 , getEnvVar >>= \env -> msum [+                       probeNullEnv env+                     , probeEnvFile env+                     , probeEnvName env+                     , envError     env+                     ]+                 , notIfHideAllPackages >> msum [+                       findLocalEnvFile >>= probeEnvFile+                     , probeEnvName defaultEnvName+                     ]+                 ]+    case mPkgEnv of+      Nothing ->+        -- No environment found. Leave DynFlags unchanged.+        return dflags+      Just "-" -> do+        -- Explicitly disabled environment file. Leave DynFlags unchanged.+        return dflags+      Just envfile -> do+        content <- readFile envfile+        compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)+        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags++        return dflags'+  where+    -- Loading environments (by name or by location)++    namedEnvPath :: String -> MaybeT IO FilePath+    namedEnvPath name = do+     appdir <- versionedAppDir dflags+     return $ appdir </> "environments" </> name++    probeEnvName :: String -> MaybeT IO FilePath+    probeEnvName name = probeEnvFile =<< namedEnvPath name++    probeEnvFile :: FilePath -> MaybeT IO FilePath+    probeEnvFile path = do+      guard =<< liftMaybeT (doesFileExist path)+      return path++    probeNullEnv :: FilePath -> MaybeT IO FilePath+    probeNullEnv "-" = return "-"+    probeNullEnv _   = mzero++    -- Various ways to define which environment to use++    getCmdLineArg :: MaybeT IO String+    getCmdLineArg = MaybeT $ return $ packageEnv dflags++    getEnvVar :: MaybeT IO String+    getEnvVar = do+      mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT"+      case mvar of+        Right var -> return var+        Left err  -> if isDoesNotExistError err then mzero+                                                else liftMaybeT $ throwIO err++    notIfHideAllPackages :: MaybeT IO ()+    notIfHideAllPackages =+      guard (not (gopt Opt_HideAllPackages dflags))++    defaultEnvName :: String+    defaultEnvName = "default"++    -- e.g. .ghc.environment.x86_64-linux-7.6.3+    localEnvFileName :: FilePath+    localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags++    -- Search for an env file, starting in the current dir and looking upwards.+    -- Fail if we get to the users home dir or the filesystem root. That is,+    -- we don't look for an env file in the user's home dir. The user-wide+    -- env lives in ghc's versionedAppDir/environments/default+    findLocalEnvFile :: MaybeT IO FilePath+    findLocalEnvFile = do+        curdir  <- liftMaybeT getCurrentDirectory+        homedir <- tryMaybeT getHomeDirectory+        let probe dir | isDrive dir || dir == homedir+                      = mzero+            probe dir = do+              let file = dir </> localEnvFileName+              exists <- liftMaybeT (doesFileExist file)+              if exists+                then return file+                else probe (takeDirectory dir)+        probe curdir++    -- Error reporting++    cmdLineError :: String -> MaybeT IO a+    cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $+      "Package environment " ++ show env ++ " not found"++    envError :: String -> MaybeT IO a+    envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $+         "Package environment "+      ++ show env+      ++ " (specified in GHC_ENVIRONMENT) not found"
compiler/main/GhcMake.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2011@@ -44,7 +46,7 @@ import HeaderInfo import HscTypes import Module-import TcIface          ( typecheckIface )+import GHC.IfaceToCore  ( typecheckIface ) import TcRnMonad        ( initIfaceCheck ) import HscMain @@ -319,23 +321,23 @@          withDash = (<+>) (text "-") -        matchingStr :: String -> PackageConfig -> Bool+        matchingStr :: String -> UnitInfo -> Bool         matchingStr str p                 =  str == sourcePackageIdString p                 || str == packageNameString p -        matching :: DynFlags -> PackageArg -> PackageConfig -> Bool+        matching :: DynFlags -> PackageArg -> UnitInfo -> Bool         matching _ (PackageArg str) p = matchingStr str p         matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p          -- For wired-in packages, we have to unwire their id,         -- otherwise they won't match package flags-        realUnitId :: DynFlags -> PackageConfig -> UnitId+        realUnitId :: DynFlags -> UnitInfo -> UnitId         realUnitId dflags           = unwireUnitId dflags           . DefiniteUnitId           . DefUnitId-          . installedPackageConfigId+          . installedUnitInfoId  -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally@@ -841,7 +843,7 @@                                  -> isObjectLinkable l && t == linkableTime l                                 _other  -> True                 -- why '>=' rather than '>' above?  If the filesystem stores-                -- times to the nearset second, we may occasionally find that+                -- times to the nearest second, we may occasionally find that                 -- the object & source have the same modification time,                 -- especially if the source was automatically generated                 -- and compiled.  Using >= is slightly unsafe, but it matches@@ -1464,7 +1466,7 @@                         -- Space-saving: delete the old HPT entry                         -- for mod BUT if mod is a hs-boot                         -- node, don't delete it.  For the-                        -- interface, the HPT entry is probaby for the+                        -- interface, the HPT entry is probably for the                         -- main Haskell source file.  Deleting it                         -- would force the real module to be recompiled                         -- every time.@@ -1781,7 +1783,7 @@ depends on the .hs-boot file, so that everyone points to the proper TyCons, Ids etc. defined by the real module, not the boot module. Fortunately re-generating a ModDetails from a ModIface is easy: the-function TcIface.typecheckIface does exactly that.+function GHC.IfaceToCore.typecheckIface does exactly that.  Picking the modules to re-typecheck is slightly tricky.  Starting from the module graph consisting of the modules that have already been@@ -2389,7 +2391,7 @@                  else return Nothing             -- We have to repopulate the Finder's cache for file targets-           -- because the file might not even be on the regular serach path+           -- because the file might not even be on the regular search path            -- and it was likely flushed in depanal. This is not technically            -- needed when we're called from sumariseModule but it shouldn't            -- hurt.
compiler/main/GhcPlugins.hs view
@@ -87,7 +87,7 @@ import FastString import Data.Maybe -import IfaceEnv         ( lookupOrigIO )+import GHC.Iface.Env    ( lookupOrigIO ) import GhcPrelude import MonadUtils       ( mapMaybeM ) import GHC.ThToHs       ( thRdrNameGuesses )
compiler/main/HscMain.hs view
@@ -74,7 +74,7 @@     , hscCompileCoreExpr'       -- We want to make sure that we export enough to be able to redefine       -- hscFileFrontEnd in client code-    , hscParse', hscSimplify', hscDesugar', tcRnModule'+    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen     , getHscEnv     , hscSimpleIface'     , oneShotMsg@@ -113,18 +113,18 @@ import Lexer import SrcLoc import TcRnDriver-import TcIface          ( typecheckIface )+import GHC.IfaceToCore  ( typecheckIface ) import TcRnMonad import TcHsSyn          ( ZonkFlexi (DefaultFlexi) ) import NameCache        ( initNameCache )-import LoadIface        ( ifaceStats, initExternalPackageState )+import GHC.Iface.Load   ( ifaceStats, initExternalPackageState ) import PrelInfo-import MkIface+import GHC.Iface.Utils import Desugar import SimplCore-import TidyPgm+import GHC.Iface.Tidy import GHC.CoreToStg.Prep-import GHC.CoreToStg        ( coreToStg )+import GHC.CoreToStg    ( coreToStg ) import GHC.Stg.Syntax import GHC.Stg.FVs      ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg )@@ -133,11 +133,11 @@ import ProfInit import TyCon import Name-import Cmm-import CmmParse         ( parseCmmFile )-import CmmBuildInfoTables-import CmmPipeline-import CmmInfo+import GHC.Cmm+import GHC.Cmm.Parser         ( parseCmmFile )+import GHC.Cmm.Info.Build+import GHC.Cmm.Pipeline+import GHC.Cmm.Info import CodeOutput import InstEnv import FamInstEnv@@ -175,10 +175,10 @@ import Data.Set (Set) import Control.DeepSeq (force) -import HieAst           ( mkHieFile )-import HieTypes         ( getAsts, hie_asts, hie_module )-import HieBin           ( readHieFile, writeHieFile , hie_file_result)-import HieDebug         ( diffFile, validateScopes )+import GHC.Iface.Ext.Ast    ( mkHieFile )+import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)+import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )  #include "HsVersions.h" @@ -1017,9 +1017,10 @@ -- -- The code for this is quite tricky as the whole algorithm is done in a few -- distinct phases in different parts of the code base. See--- RnNames.rnImportDecl for where package trust dependencies for a module are--- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust--- Transitively] and the Note [RnNames . Trust Own Package].+-- GHC.Rename.Names.rnImportDecl for where package trust dependencies for a+-- module are collected and unioned.  Specifically see the Note [Tracking Trust+-- Transitively] in GHC.Rename.Names and the Note [Trust Own Package] in+-- GHC.Rename.Names. checkSafeImports :: TcGblEnv -> Hsc TcGblEnv checkSafeImports tcg_env     = do@@ -1454,7 +1455,8 @@              ------------------  Code output -----------------------             rawcmms0 <- {-# SCC "cmmToRawCmm" #-}-                      cmmToRawCmm dflags cmms+                      lookupHook cmmToRawCmmHook+                        (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms              let dump a = do                   unless (null a) $@@ -1516,7 +1518,8 @@         unless (null cmmgroup) $           dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"             FormatCMM (ppr cmmgroup)-        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)+        rawCmms <- lookupHook cmmToRawCmmHook+                     (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup)         _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []              rawCmms         return ()@@ -1544,7 +1547,7 @@      let cmm_stream :: Stream IO CmmGroup ()         cmm_stream = {-# SCC "StgToCmm" #-}-            StgToCmm.codeGen dflags this_mod data_tycons+            lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons                            cost_centre_info stg_binds_w_fvs hpc_info          -- codegen consumes a stream of CmmGroup, and produces a new@@ -1743,7 +1746,7 @@                        , isExternalName (idName id)                        , not (isDFunId id || isImplicitId id) ]             -- We only need to keep around the external bindings-            -- (as decided by TidyPgm), since those are the only ones+            -- (as decided by GHC.Iface.Tidy), since those are the only ones             -- that might later be looked up by name.  But we can exclude             --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes             --    - Implicit Ids, which are implicit in tcs
compiler/main/HscStats.hs view
@@ -21,7 +21,7 @@ import Data.Char  -- | Source Statistics-ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc+ppSourceStats :: Bool -> Located HsModule -> SDoc ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))   = (if short then hcat else vcat)         (map pp_val
compiler/main/InteractiveEval.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,     RecordWildCards, BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007@@ -56,9 +58,9 @@ import GHC.Hs import HscTypes import InstEnv-import IfaceEnv   ( newInteractiveBinder )-import FamInstEnv ( FamInst )-import CoreFVs    ( orphNamesOfFamInst )+import GHC.Iface.Env   ( newInteractiveBinder )+import FamInstEnv      ( FamInst )+import CoreFVs         ( orphNamesOfFamInst ) import TyCon import Type             hiding( typeKind ) import GHC.Types.RepType@@ -385,8 +387,10 @@     | EvalComplete alloc (EvalException e) <- status     = return (ExecComplete (Left (fromSerializableException e)) alloc) +#if __GLASGOW_HASKELL__ <= 810     | otherwise     = panic "not_tracing" -- actually exhaustive, but GHC can't tell+#endif   resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
compiler/main/PprTyThing.hs view
@@ -22,11 +22,11 @@ import GhcPrelude  import Type    ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType )-import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)   , showToHeader, pprIfaceDecl ) import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe )-import MkIface ( tyThingToIfaceDecl )+import GHC.Iface.Utils ( tyThingToIfaceDecl ) import FamInstEnv( FamInst(..), FamFlavor(..) ) import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) import Name@@ -36,28 +36,28 @@ -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API -{- Note [Pretty printing via IfaceSyn]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Our general plan for prett-printing+{- Note [Pretty printing via Iface syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our general plan for pretty-printing   - Types   - TyCons   - Classes   - Pattern synonyms   ...etc... -is to convert them to IfaceSyn, and pretty-print that. For example+is to convert them to Iface syntax, and pretty-print that. For example   - pprType converts a Type to an IfaceType, and pretty prints that.   - pprTyThing converts the TyThing to an IfaceDecl,     and pretty prints that. -So IfaceSyn play a dual role:+So Iface syntax plays a dual role:   - it's the internal version of an interface files   - it's used for pretty-printing  Why do this?  * A significant reason is that we need to be able-  to pretty-print IfaceSyn (to display Foo.hi), and it was a+  to pretty-print Iface syntax (to display Foo.hi), and it was a   pain to duplicate masses of pretty-printing goop, esp for   Type and IfaceType. @@ -72,7 +72,7 @@  * Interface files contains fast-strings, not uniques, so the very same   tidying must take place when we convert to IfaceDecl. E.g.-  MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,+  GHC.Iface.Utils.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,   Class etc) to an IfaceDecl.    Bottom line: IfaceDecls are already 'tidy', so it's straightforward@@ -87,17 +87,17 @@  Consequences: -- IfaceSyn (and IfaceType) must contain enough information to+- Iface syntax (and IfaceType) must contain enough information to   print nicely.  Hence, for example, the IfaceAppArgs type, which   allows us to suppress invisible kind arguments in types-  (see Note [Suppressing invisible arguments] in IfaceType)+  (see Note [Suppressing invisible arguments] in GHC.Iface.Type)  - In a few places we have info that is used only for pretty-printing,-  and is totally ignored when turning IfaceSyn back into TyCons-  etc (in TcIface). For example, IfaceClosedSynFamilyTyCon+  and is totally ignored when turning Iface syntax back into Core+  (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon   stores a [IfaceAxBranch] that is used only for pretty-printing. -- See Note [Free tyvars in IfaceType] in IfaceType+- See Note [Free tyvars in IfaceType] in GHC.Iface.Type  See #7730, #8776 for details   -} @@ -121,7 +121,7 @@     hang (text "type instance"             <+> pprUserForAll (mkTyVarBinders Specified tvs)                 -- See Note [Printing foralls in type family instances]-                -- in IfaceType+                -- in GHC.Iface.Type             <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)        2 (equals <+> ppr rhs)
compiler/main/StaticPtrTable.hs view
@@ -124,7 +124,7 @@  import GhcPrelude -import CLabel+import GHC.Cmm.CLabel import CoreSyn import CoreUtils (collectMakeStaticArgs) import DataCon
compiler/main/SysTools/Settings.hs view
@@ -108,7 +108,7 @@   ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"   ldIsGnuLd               <- getBooleanSetting "ld is GNU ld" -  let pkgconfig_path = installed "package.conf.d"+  let globalpkgdb_path = installed "package.conf.d"       ghc_usage_msg_path  = installed "ghc-usage.txt"       ghci_usage_msg_path = installed "ghci-usage.txt" @@ -186,7 +186,7 @@       , fileSettings_ghciUsagePath  = ghci_usage_msg_path       , fileSettings_toolDir        = mtool_dir       , fileSettings_topDir         = top_dir-      , fileSettings_systemPackageConfig = pkgconfig_path+      , fileSettings_globalPackageDatabase = globalpkgdb_path       }      , sToolSettings = ToolSettings
− compiler/main/TidyPgm.hs 
@@ -1,1486 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section{Tidying up Core}--}--{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}--module TidyPgm (-       mkBootModDetailsTc, tidyProgram-   ) where--#include "HsVersions.h"--import GhcPrelude--import TcRnTypes-import DynFlags-import CoreSyn-import CoreUnfold-import CoreFVs-import CoreTidy-import CoreMonad-import GHC.CoreToStg.Prep-import CoreUtils        (rhsIsStatic)-import CoreStats        (coreBindsStats, CoreStats(..))-import CoreSeq          (seqBinds)-import CoreLint-import Literal-import Rules-import PatSyn-import ConLike-import CoreArity        ( exprArity, exprBotStrictness_maybe )-import StaticPtrTable-import VarEnv-import VarSet-import Var-import Id-import MkId             ( mkDictSelRhs )-import IdInfo-import InstEnv-import Type             ( tidyTopType )-import Demand           ( appIsBottom, isTopSig, isBottomingSig )-import BasicTypes-import Name hiding (varName)-import NameSet-import NameCache-import Avail-import IfaceEnv-import TcEnv-import TcRnMonad-import DataCon-import TyCon-import Class-import Module-import Packages( isDllName )-import HscTypes-import Maybes-import UniqSupply-import Outputable-import Util( filterOut )-import qualified ErrUtils as Err--import Control.Monad-import Data.Function-import Data.List        ( sortBy, mapAccumL )-import Data.IORef       ( atomicModifyIORef' )--{--Constructing the TypeEnv, Instances, Rules from which the-ModIface is constructed, and which goes on to subsequent modules in---make mode.--Most of the interface file is obtained simply by serialising the-TypeEnv.  One important consequence is that if the *interface file*-has pragma info if and only if the final TypeEnv does. This is not so-important for *this* module, but it's essential for ghc --make:-subsequent compilations must not see (e.g.) the arity if the interface-file does not contain arity If they do, they'll exploit the arity;-then the arity might change, but the iface file doesn't change =>-recompilation does not happen => disaster.--For data types, the final TypeEnv will have a TyThing for the TyCon,-plus one for each DataCon; the interface file will contain just one-data type declaration, but it is de-serialised back into a collection-of TyThings.--************************************************************************-*                                                                      *-                Plan A: simpleTidyPgm-*                                                                      *-************************************************************************---Plan A: mkBootModDetails: omit pragmas, make interfaces small-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Ignore the bindings--* Drop all WiredIn things from the TypeEnv-        (we never want them in interface files)--* Retain all TyCons and Classes in the TypeEnv, to avoid-        having to find which ones are mentioned in the-        types of exported Ids--* Trim off the constructors of non-exported TyCons, both-        from the TyCon and from the TypeEnv--* Drop non-exported Ids from the TypeEnv--* Tidy the types of the DFunIds of Instances,-  make them into GlobalIds, (they already have External Names)-  and add them to the TypeEnv--* Tidy the types of the (exported) Ids in the TypeEnv,-  make them into GlobalIds (they already have External Names)--* Drop rules altogether--* Tidy the bindings, to ensure that the Caf and Arity-  information is correct for each top-level binder; the-  code generator needs it. And to ensure that local names have-  distinct OccNames in case of object-file splitting--* If this an hsig file, drop the instances altogether too (they'll-  get pulled in by the implicit module import.--}---- This is Plan A: make a small type env when typechecking only,--- or when compiling a hs-boot file, or simply when not using -O------ We don't look at the bindings at all -- there aren't any--- for hs-boot files--mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails-mkBootModDetailsTc hsc_env-        TcGblEnv{ tcg_exports          = exports,-                  tcg_type_env         = type_env, -- just for the Ids-                  tcg_tcs              = tcs,-                  tcg_patsyns          = pat_syns,-                  tcg_insts            = insts,-                  tcg_fam_insts        = fam_insts,-                  tcg_complete_matches = complete_sigs,-                  tcg_mod              = this_mod-                }-  = -- This timing isn't terribly useful since the result isn't forced, but-    -- the message is useful to locating oneself in the compilation process.-    Err.withTiming dflags-                   (text "CoreTidy"<+>brackets (ppr this_mod))-                   (const ()) $-    return (ModDetails { md_types         = type_env'-                       , md_insts         = insts'-                       , md_fam_insts     = fam_insts-                       , md_rules         = []-                       , md_anns          = []-                       , md_exports       = exports-                       , md_complete_sigs = complete_sigs-                       })-  where-    dflags = hsc_dflags hsc_env--    -- Find the LocalIds in the type env that are exported-    -- Make them into GlobalIds, and tidy their types-    ---    -- It's very important to remove the non-exported ones-    -- because we don't tidy the OccNames, and if we don't remove-    -- the non-exported ones we'll get many things with the-    -- same name in the interface file, giving chaos.-    ---    -- Do make sure that we keep Ids that are already Global.-    -- When typechecking an .hs-boot file, the Ids come through as-    -- GlobalIds.-    final_ids = [ globaliseAndTidyBootId id-                | id <- typeEnvIds type_env-                , keep_it id ]--    final_tcs  = filterOut isWiredIn tcs-                 -- See Note [Drop wired-in things]-    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts-    insts'     = mkFinalClsInsts type_env1 insts-    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns-    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1--    -- Default methods have their export flag set (isExportedId),-    -- but everything else doesn't (yet), because this is-    -- pre-desugaring, so we must test against the exports too.-    keep_it id | isWiredInName id_name           = False-                 -- See Note [Drop wired-in things]-               | isExportedId id                 = True-               | id_name `elemNameSet` exp_names = True-               | otherwise                       = False-               where-                 id_name = idName id--    exp_names = availsToNameSet exports--lookupFinalId :: TypeEnv -> Id -> Id-lookupFinalId type_env id-  = case lookupTypeEnv type_env (idName id) of-      Just (AnId id') -> id'-      _ -> pprPanic "lookup_final_id" (ppr id)--mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]-mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))--mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]-mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))--extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv-extendTypeEnvWithPatSyns tidy_patsyns type_env-  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]--globaliseAndTidyBootId :: Id -> Id--- For a LocalId with an External Name,--- makes it into a GlobalId---     * unchanged Name (might be Internal or External)---     * unchanged details---     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)---     * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)-globaliseAndTidyBootId id-  = globaliseId id `setIdType`      tidyTopType (idType id)-                   `setIdUnfolding` BootUnfolding--{--************************************************************************-*                                                                      *-        Plan B: tidy bindings, make TypeEnv full of IdInfo-*                                                                      *-************************************************************************--Plan B: include pragmas, make interfaces-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Step 1: Figure out which Ids are externally visible-          See Note [Choosing external Ids]--* Step 2: Gather the externally visible rules, separately from-          the top-level bindings.-          See Note [Finding external rules]--* Step 3: Tidy the bindings, externalising appropriate Ids-          See Note [Tidy the top-level bindings]--* Drop all Ids from the TypeEnv, and add all the External Ids from-  the bindings.  (This adds their IdInfo to the TypeEnv; and adds-  floated-out Ids that weren't even in the TypeEnv before.)--Note [Choosing external Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also the section "Interface stability" in the-recompilation-avoidance commentary:-  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance--First we figure out which Ids are "external" Ids.  An-"external" Id is one that is visible from outside the compilation-unit.  These are-  a) the user exported ones-  b) the ones bound to static forms-  c) ones mentioned in the unfoldings, workers, or-     rules of externally-visible ones--While figuring out which Ids are external, we pick a "tidy" OccName-for each one.  That is, we make its OccName distinct from the other-external OccNames in this module, so that in interface files and-object code we can refer to it unambiguously by its OccName.  The-OccName for each binder is prefixed by the name of the exported Id-that references it; e.g. if "f" references "x" in its unfolding, then-"x" is renamed to "f_x".  This helps distinguish the different "x"s-from each other, and means that if "f" is later removed, things that-depend on the other "x"s will not need to be recompiled.  Of course,-if there are multiple "f_x"s, then we have to disambiguate somehow; we-use "f_x0", "f_x1" etc.--As far as possible we should assign names in a deterministic fashion.-Each time this module is compiled with the same options, we should end-up with the same set of external names with the same types.  That is,-the ABI hash in the interface should not change.  This turns out to be-quite tricky, since the order of the bindings going into the tidy-phase is already non-deterministic, as it is based on the ordering of-Uniques, which are assigned unpredictably.--To name things in a stable way, we do a depth-first-search of the-bindings, starting from the exports sorted by name.  This way, as long-as the bindings themselves are deterministic (they sometimes aren't!),-the order in which they are presented to the tidying phase does not-affect the names we assign.--Note [Tidy the top-level bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Next we traverse the bindings top to bottom.  For each *top-level*-binder-- 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,-    reflecting the fact that from now on we regard it as a global,-    not local, Id-- 2. Give it a system-wide Unique.-    [Even non-exported things need system-wide Uniques because the-    byte-code generator builds a single Name->BCO symbol table.]--    We use the NameCache kept in the HscEnv as the-    source of such system-wide uniques.--    For external Ids, use the original-name cache in the NameCache-    to ensure that the unique assigned is the same as the Id had-    in any previous compilation run.-- 3. Rename top-level Ids according to the names we chose in step 1.-    If it's an external Id, make it have a External Name, otherwise-    make it have an Internal Name.  This is used by the code generator-    to decide whether to make the label externally visible-- 4. Give it its UTTERLY FINAL IdInfo; in ptic,-        * its unfolding, if it should have one--        * its arity, computed from the number of visible lambdas--        * its CAF info, computed from what is free in its RHS---Finally, substitute these new top-level binders consistently-throughout, including in unfoldings.  We also tidy binders in-RHSs, so that they print nicely in interfaces.--}--tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)-tidyProgram hsc_env  (ModGuts { mg_module    = mod-                              , mg_exports   = exports-                              , mg_rdr_env   = rdr_env-                              , mg_tcs       = tcs-                              , mg_insts     = cls_insts-                              , mg_fam_insts = fam_insts-                              , mg_binds     = binds-                              , mg_patsyns   = patsyns-                              , mg_rules     = imp_rules-                              , mg_anns      = anns-                              , mg_complete_sigs = complete_sigs-                              , mg_deps      = deps-                              , mg_foreign   = foreign_stubs-                              , mg_foreign_files = foreign_files-                              , mg_hpc_info  = hpc_info-                              , mg_modBreaks = modBreaks-                              })--  = Err.withTiming dflags-                   (text "CoreTidy"<+>brackets (ppr mod))-                   (const ()) $-    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags-              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags-              ; print_unqual = mkPrintUnqualified dflags rdr_env-              ; implicit_binds = concatMap getImplicitBinds tcs-              }--        ; (unfold_env, tidy_occ_env)-              <- chooseExternalIds hsc_env mod omit_prags expose_all-                                   binds implicit_binds imp_rules-        ; let { (trimmed_binds, trimmed_rules)-                    = findExternalRules omit_prags binds imp_rules unfold_env }--        ; (tidy_env, tidy_binds)-                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds--          -- See Note [Grand plan for static forms] in StaticPtrTable.-        ; (spt_entries, tidy_binds') <--             sptCreateStaticBinds hsc_env mod tidy_binds-        ; let { spt_init_code = sptModuleInitCode mod spt_entries-              ; add_spt_init_code =-                  case hscTarget dflags of-                    -- If we are compiling for the interpreter we will insert-                    -- any necessary SPT entries dynamically-                    HscInterpreted -> id-                    -- otherwise add a C stub to do so-                    _              -> (`appendStubC` spt_init_code)--              -- The completed type environment is gotten from-              --      a) the types and classes defined here (plus implicit things)-              --      b) adding Ids with correct IdInfo, including unfoldings,-              --              gotten from the bindings-              -- From (b) we keep only those Ids with External names;-              --          the CoreTidy pass makes sure these are all and only-              --          the externally-accessible ones-              -- This truncates the type environment to include only the-              -- exported Ids and things needed from them, which saves space-              ---              -- See Note [Don't attempt to trim data types]-              ; final_ids  = [ if omit_prags then trimId id else id-                             | id <- bindersOfBinds tidy_binds-                             , isExternalName (idName id)-                             , not (isWiredIn id)-                             ]   -- See Note [Drop wired-in things]--              ; final_tcs      = filterOut isWiredIn tcs-                                 -- See Note [Drop wired-in things]-              ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts-              ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts-              ; tidy_patsyns   = mkFinalPatSyns  type_env patsyns-              ; tidy_type_env  = extendTypeEnvWithPatSyns tidy_patsyns type_env-              ; tidy_rules     = tidyRules tidy_env trimmed_rules--              ; -- See Note [Injecting implicit bindings]-                all_tidy_binds = implicit_binds ++ tidy_binds'--              -- Get the TyCons to generate code for.  Careful!  We must use-              -- the untidied TyCons here, because we need-              --  (a) implicit TyCons arising from types and classes defined-              --      in this module-              --  (b) wired-in TyCons, which are normally removed from the-              --      TypeEnv we put in the ModDetails-              --  (c) Constructors even if they are not exported (the-              --      tidied TypeEnv has trimmed these away)-              ; alg_tycons = filter isAlgTyCon tcs-              }--        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules--          -- If the endPass didn't print the rules, but ddump-rules is-          -- on, print now-        ; unless (dopt Opt_D_dump_simpl dflags) $-            Err.dumpIfSet_dyn dflags Opt_D_dump_rules-              (showSDoc dflags (ppr CoreTidy <+> text "rules"))-              Err.FormatText-              (pprRulesForUser dflags tidy_rules)--          -- Print one-line size info-        ; let cs = coreBindsStats tidy_binds-        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"-            Err.FormatText-            (text "Tidy size (terms,types,coercions)"-             <+> ppr (moduleName mod) <> colon-             <+> int (cs_tm cs)-             <+> int (cs_ty cs)-             <+> int (cs_co cs) )--        ; return (CgGuts { cg_module   = mod,-                           cg_tycons   = alg_tycons,-                           cg_binds    = all_tidy_binds,-                           cg_foreign  = add_spt_init_code foreign_stubs,-                           cg_foreign_files = foreign_files,-                           cg_dep_pkgs = map fst $ dep_pkgs deps,-                           cg_hpc_info = hpc_info,-                           cg_modBreaks = modBreaks,-                           cg_spt_entries = spt_entries },--                   ModDetails { md_types     = tidy_type_env,-                                md_rules     = tidy_rules,-                                md_insts     = tidy_cls_insts,-                                md_fam_insts = fam_insts,-                                md_exports   = exports,-                                md_anns      = anns,      -- are already tidy-                                md_complete_sigs = complete_sigs-                              })-        }-  where-    dflags = hsc_dflags hsc_env-----------------------------trimId :: Id -> Id-trimId id-  | not (isImplicitId id)-  = id `setIdInfo` vanillaIdInfo-  | otherwise-  = id--{- Note [Drop wired-in things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We never put wired-in TyCons or Ids in an interface file.-They are wired-in, so the compiler knows about them already.--Note [Don't attempt to trim data types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For some time GHC tried to avoid exporting the data constructors-of a data type if it wasn't strictly necessary to do so; see #835.-But "strictly necessary" accumulated a longer and longer list-of exceptions, and finally I gave up the battle:--    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11-    Author: Simon Peyton Jones <simonpj@microsoft.com>-    Date:   Thu Dec 6 16:03:16 2012 +0000--    Stop attempting to "trim" data types in interface files--    Without -O, we previously tried to make interface files smaller-    by not including the data constructors of data types.  But-    there are a lot of exceptions, notably when Template Haskell is-    involved or, more recently, DataKinds.--    However #7445 shows that even without TemplateHaskell, using-    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ-    is enough to require us to expose the data constructors.--    So I've given up on this "optimisation" -- it's probably not-    important anyway.  Now I'm simply not attempting to trim off-    the data constructors.  The gain in simplicity is worth the-    modest cost in interface file growth, which is limited to the-    bits reqd to describe those data constructors.--************************************************************************-*                                                                      *-        Implicit bindings-*                                                                      *-************************************************************************--Note [Injecting implicit bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We inject the implicit bindings right at the end, in CoreTidy.-Some of these bindings, notably record selectors, are not-constructed in an optimised form.  E.g. record selector for-        data T = MkT { x :: {-# UNPACK #-} !Int }-Then the unfolding looks like-        x = \t. case t of MkT x1 -> let x = I# x1 in x-This generates bad code unless it's first simplified a bit.  That is-why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of-optimisation first.  (Only matters when the selector is used curried;-eg map x ys.)  See #2070.--[Oct 09: in fact, record selectors are no longer implicit Ids at all,-because we really do want to optimise them properly. They are treated-much like any other Id.  But doing "light" optimisation on an implicit-Id still makes sense.]--At one time I tried injecting the implicit bindings *early*, at the-beginning of SimplCore.  But that gave rise to real difficulty,-because GlobalIds are supposed to have *fixed* IdInfo, but the-simplifier and other core-to-core passes mess with IdInfo all the-time.  The straw that broke the camels back was when a class selector-got the wrong arity -- ie the simplifier gave it arity 2, whereas-importing modules were expecting it to have arity 1 (#2844).-It's much safer just to inject them right at the end, after tidying.--Oh: two other reasons for injecting them late:--  - If implicit Ids are already in the bindings when we start TidyPgm,-    we'd have to be careful not to treat them as external Ids (in-    the sense of chooseExternalIds); else the Ids mentioned in *their*-    RHSs will be treated as external and you get an interface file-    saying      a18 = <blah>-    but nothing referring to a18 (because the implicit Id is the-    one that does, and implicit Ids don't appear in interface files).--  - More seriously, the tidied type-envt will include the implicit-    Id replete with a18 in its unfolding; but we won't take account-    of a18 when computing a fingerprint for the class; result chaos.--There is one sort of implicit binding that is injected still later,-namely those for data constructor workers. Reason (I think): it's-really just a code generation trick.... binding itself makes no sense.-See Note [Data constructor workers] in CorePrep.--}--getImplicitBinds :: TyCon -> [CoreBind]-getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc-  where-    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)--getTyConImplicitBinds :: TyCon -> [CoreBind]-getTyConImplicitBinds tc-  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in MkId-  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))--getClassImplicitBinds :: Class -> [CoreBind]-getClassImplicitBinds cls-  = [ NonRec op (mkDictSelRhs cls val_index)-    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]--get_defn :: Id -> CoreBind-get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))--{--************************************************************************-*                                                                      *-\subsection{Step 1: finding externals}-*                                                                      *-************************************************************************--See Note [Choosing external Ids].--}--type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})-  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)-  -- The Unique is unchanged.  If the new Name is external, it will be-  -- visible in the interface file.-  ---  -- Bool => expose unfolding or not.--chooseExternalIds :: HscEnv-                  -> Module-                  -> Bool -> Bool-                  -> [CoreBind]-                  -> [CoreBind]-                  -> [CoreRule]-                  -> IO (UnfoldEnv, TidyOccEnv)-                  -- Step 1 from the notes above--chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules-  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env-       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders-       ; tidy_internal internal_ids unfold_env1 occ_env1 }- where-  nc_var = hsc_NC hsc_env--  -- init_ext_ids is the initial list of Ids that should be-  -- externalised.  It serves as the starting point for finding a-  -- deterministic, tidy, renaming for all external Ids in this-  -- module.-  ---  -- It is sorted, so that it has a deterministic order (i.e. it's the-  -- same list every time this module is compiled), in contrast to the-  -- bindings, which are ordered non-deterministically.-  init_work_list = zip init_ext_ids init_ext_ids-  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders--  -- An Id should be external if either (a) it is exported,-  -- (b) it appears in the RHS of a local rule for an imported Id, or-  -- See Note [Which rules to expose]-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars--  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules--  binders          = map fst $ flattenBinds binds-  implicit_binders = bindersOfBinds implicit_binds-  binder_set       = mkVarSet binders--  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,-                                let name = idName bndr,-                                isExternalName name ]-                -- In computing our "avoids" list, we must include-                --      all implicit Ids-                --      all things with global names (assigned once and for-                --                                      all by the renamer)-                -- since their names are "taken".-                -- The type environment is a convenient source of such things.-                -- In particular, the set of binders doesn't include-                -- implicit Ids at this stage.--        -- We also make sure to avoid any exported binders.  Consider-        --      f{-u1-} = 1     -- Local decl-        --      ...-        --      f{-u2-} = 2     -- Exported decl-        ---        -- The second exported decl must 'get' the name 'f', so we-        -- have to put 'f' in the avoids list before we get to the first-        -- decl.  tidyTopId then does a no-op on exported binders.-  init_occ_env = initTidyOccEnv avoids---  search :: [(Id,Id)]    -- The work-list: (external id, referring id)-                         -- Make a tidy, external Name for the external id,-                         --   add it to the UnfoldEnv, and do the same for the-                         --   transitive closure of Ids it refers to-                         -- The referring id is used to generate a tidy-                         ---  name for the external id-         -> UnfoldEnv    -- id -> (new Name, show_unfold)-         -> TidyOccEnv   -- occ env for choosing new Names-         -> IO (UnfoldEnv, TidyOccEnv)--  search [] unfold_env occ_env = return (unfold_env, occ_env)--  search ((idocc,referrer) : rest) unfold_env occ_env-    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env-    | otherwise = do-      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc-      let-          (new_ids, show_unfold)-                | omit_prags = ([], False)-                | otherwise  = addExternal expose_all refined_id--                -- 'idocc' is an *occurrence*, but we need to see the-                -- unfolding in the *definition*; so look up in binder_set-          refined_id = case lookupVarSet binder_set idocc of-                         Just id -> id-                         Nothing -> WARN( True, ppr idocc ) idocc--          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)-          referrer' | isExportedId refined_id = refined_id-                    | otherwise               = referrer-      ---      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'--  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv-                -> IO (UnfoldEnv, TidyOccEnv)-  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)-  tidy_internal (id:ids) unfold_env occ_env = do-      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id-      let unfold_env' = extendVarEnv unfold_env id (name',False)-      tidy_internal ids unfold_env' occ_env'--addExternal :: Bool -> Id -> ([Id], Bool)-addExternal expose_all id = (new_needed_ids, show_unfold)-  where-    new_needed_ids = bndrFvsInOrder show_unfold id-    idinfo         = idInfo id-    show_unfold    = show_unfolding (unfoldingInfo idinfo)-    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))-    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)-    bottoming_fn   = isBottomingSig (strictnessInfo idinfo)--        -- Stuff to do with the Id's unfolding-        -- We leave the unfolding there even if there is a worker-        -- In GHCi the unfolding is used by importers--    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })-       =  expose_all         -- 'expose_all' says to expose all-                             -- unfoldings willy-nilly--       || isStableSource src     -- Always expose things whose-                                 -- source is an inline rule--       || not (bottoming_fn      -- No need to inline bottom functions-           || never_active       -- Or ones that say not to-           || loop_breaker       -- Or that are loop breakers-           || neverUnfoldGuidance guidance)-    show_unfolding (DFunUnfolding {}) = True-    show_unfolding _                  = False--{--************************************************************************-*                                                                      *-               Deterministic free variables-*                                                                      *-************************************************************************--We want a deterministic free-variable list.  exprFreeVars gives us-a VarSet, which is in a non-deterministic order when converted to a-list.  Hence, here we define a free-variable finder that returns-the free variables in the order that they are encountered.--See Note [Choosing external Ids]--}--bndrFvsInOrder :: Bool -> Id -> [Id]-bndrFvsInOrder show_unfold id-  = run (dffvLetBndr show_unfold id)--run :: DFFV () -> [Id]-run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of-                 ((_,ids),_) -> ids--newtype DFFV a-  = DFFV (VarSet              -- Envt: non-top-level things that are in scope-                              -- we don't want to record these as free vars-      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far-      -> ((VarSet,[Var]),a))  -- Output state-    deriving (Functor)--instance Applicative DFFV where-    pure a = DFFV $ \_ st -> (st, a)-    (<*>) = ap--instance Monad DFFV where-  (DFFV m) >>= k = DFFV $ \env st ->-    case m env st of-       (st',a) -> case k a of-                     DFFV f -> f env st'--extendScope :: Var -> DFFV a -> DFFV a-extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)--extendScopeList :: [Var] -> DFFV a -> DFFV a-extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)--insert :: Var -> DFFV ()-insert v = DFFV $ \ env (set, ids) ->-           let keep_me = isLocalId v &&-                         not (v `elemVarSet` env) &&-                           not (v `elemVarSet` set)-           in if keep_me-              then ((extendVarSet set v, v:ids), ())-              else ((set,                ids),   ())---dffvExpr :: CoreExpr -> DFFV ()-dffvExpr (Var v)              = insert v-dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2-dffvExpr (Lam v e)            = extendScope v (dffvExpr e)-dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e-dffvExpr (Tick _other e)    = dffvExpr e-dffvExpr (Cast e _)           = dffvExpr e-dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)-dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $-                                (mapM_ dffvBind prs >> dffvExpr e)-dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)-dffvExpr _other               = return ()--dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()-dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)--dffvBind :: (Id, CoreExpr) -> DFFV ()-dffvBind(x,r)-  | not (isId x) = dffvExpr r-  | otherwise    = dffvLetBndr False x >> dffvExpr r-                -- Pass False because we are doing the RHS right here-                -- If you say True you'll get *exponential* behaviour!--dffvLetBndr :: Bool -> Id -> DFFV ()--- Gather the free vars of the RULES and unfolding of a binder--- We always get the free vars of a *stable* unfolding, but--- for a *vanilla* one (InlineRhs), the flag controls what happens:---   True <=> get fvs of even a *vanilla* unfolding---   False <=> ignore an InlineRhs--- For nested bindings (call from dffvBind) we always say "False" because---       we are taking the fvs of the RHS anyway--- For top-level bindings (call from addExternal, via bndrFvsInOrder)---       we say "True" if we are exposing that unfolding-dffvLetBndr vanilla_unfold id-  = do { go_unf (unfoldingInfo idinfo)-       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }-  where-    idinfo = idInfo id--    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })-       = case src of-           InlineRhs | vanilla_unfold -> dffvExpr rhs-                     | otherwise      -> return ()-           _                          -> dffvExpr rhs--    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })-             = extendScopeList bndrs $ mapM_ dffvExpr args-    go_unf _ = return ()--    go_rule (BuiltinRule {}) = return ()-    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })-      = extendScopeList bndrs (dffvExpr rhs)--{--************************************************************************-*                                                                      *-               findExternalRules-*                                                                      *-************************************************************************--Note [Finding external rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The complete rules are gotten by combining-   a) local rules for imported Ids-   b) rules embedded in the top-level Ids--There are two complications:-  * Note [Which rules to expose]-  * Note [Trimming auto-rules]--Note [Which rules to expose]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function 'expose_rule' filters out rules that mention, on the LHS,-Ids that aren't externally visible; these rules can't fire in a client-module.--The externally-visible binders are computed (by chooseExternalIds)-assuming that all orphan rules are externalised (see init_ext_ids in-function 'search'). So in fact it's a bit conservative and we may-export more than we need.  (It's a sort of mutual recursion.)--Note [Trimming auto-rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Second, with auto-specialisation we may specialise local or imported-dfuns or INLINE functions, and then later inline them.  That may leave-behind something like-   RULE "foo" forall d. f @ Int d = f_spec-where f is either local or imported, and there is no remaining-reference to f_spec except from the RULE.--Now that RULE *might* be useful to an importing module, but that is-purely speculative, and meanwhile the code is taking up space and-codegen time.  I found that binary sizes jumped by 6-10% when I-started to specialise INLINE functions (again, Note [Inline-specialisations] in Specialise).--So it seems better to drop the binding for f_spec, and the rule-itself, if the auto-generated rule is the *only* reason that it is-being kept alive.--(The RULE still might have been useful in the past; that is, it was-the right thing to have generated it in the first place.  See Note-[Inline specialisations] in Specialise.  But now it has served its-purpose, and can be discarded.)--So findExternalRules does this:-  * Remove all bindings that are kept alive *only* by isAutoRule rules-      (this is done in trim_binds)-  * Remove all auto rules that mention bindings that have been removed-      (this is done by filtering by keep_rule)--NB: if a binding is kept alive for some *other* reason (e.g. f_spec is-called in the final code), we keep the rule too.--This stuff is the only reason for the ru_auto field in a Rule.--}--findExternalRules :: Bool       -- Omit pragmas-                  -> [CoreBind]-                  -> [CoreRule] -- Local rules for imported fns-                  -> UnfoldEnv  -- Ids that are exported, so we need their rules-                  -> ([CoreBind], [CoreRule])--- See Note [Finding external rules]-findExternalRules omit_prags binds imp_id_rules unfold_env-  = (trimmed_binds, filter keep_rule all_rules)-  where-    imp_rules         = filter expose_rule imp_id_rules-    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules--    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet-                           | otherwise       = ruleRhsFreeVars rule--    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds--    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs-        -- Remove rules that make no sense, because they mention a-        -- local binder (on LHS or RHS) that we have now discarded.-        -- (NB: ruleFreeVars only includes LocalIds)-        ---        -- LHS: we have already filtered out rules that mention internal Ids-        --     on LHS but that isn't enough because we might have by now-        --     discarded a binding with an external Id. (How?-        --     chooseExternalIds is a bit conservative.)-        ---        -- RHS: the auto rules that might mention a binder that has-        --      been discarded; see Note [Trimming auto-rules]--    expose_rule rule-        | omit_prags = False-        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)-                -- Don't expose a rule whose LHS mentions a locally-defined-                -- Id that is completely internal (i.e. not visible to an-                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.-                -- See Note [Which rules to expose]--    is_external_id id = case lookupVarEnv unfold_env id of-                          Just (name, _) -> isExternalName name-                          Nothing        -> False--    trim_binds :: [CoreBind]-               -> ( [CoreBind]   -- Trimmed bindings-                  , VarSet       -- Binders of those bindings-                  , VarSet       -- Free vars of those bindings + rhs of user rules-                                 -- (we don't bother to delete the binders)-                  , [CoreRule])  -- All rules, imported + from the bindings-    -- This function removes unnecessary bindings, and gathers up rules from-    -- the bindings we keep.  See Note [Trimming auto-rules]-    trim_binds []  -- Base case, start with imp_user_rule_fvs-       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)--    trim_binds (bind:binds)-       | any needed bndrs    -- Keep binding-       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )-       | otherwise           -- Discard binding altogether-       = stuff-       where-         stuff@(binds', bndr_set, needed_fvs, rules)-                       = trim_binds binds-         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs--         bndrs         = bindersOf  bind-         rhss          = rhssOfBind bind-         bndr_set'     = bndr_set `extendVarSetList` bndrs--         needed_fvs'   = needed_fvs                                   `unionVarSet`-                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`-                              -- Ignore type variables in the type of bndrs-                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`-                         mapUnionVarSet user_rule_rhs_fvs local_rules-            -- In needed_fvs', we don't bother to delete binders from the fv set--         local_rules  = [ rule-                        | id <- bndrs-                        , is_external_id id   -- Only collect rules for external Ids-                        , rule <- idCoreRules id-                        , expose_rule rule ]  -- and ones that can fire in a client--{--************************************************************************-*                                                                      *-               tidyTopName-*                                                                      *-************************************************************************--This is where we set names to local/global based on whether they really are-externally visible (see comment at the top of this module).  If the name-was previously local, we have to give it a unique occurrence name if-we intend to externalise it.--}--tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv-            -> Id -> IO (TidyOccEnv, Name)-tidyTopName mod nc_var maybe_ref occ_env id-  | global && internal = return (occ_env, localiseName name)--  | global && external = return (occ_env, name)-        -- Global names are assumed to have been allocated by the renamer,-        -- so they already have the "right" unique-        -- And it's a system-wide unique too--  -- Now we get to the real reason that all this is in the IO Monad:-  -- we have to update the name cache in a nice atomic fashion--  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local-                            ; return (occ_env', new_local_name) }-        -- Even local, internal names must get a unique occurrence, because-        -- if we do -split-objs we externalise the name later, in the code generator-        ---        -- Similarly, we must make sure it has a system-wide Unique, because-        -- the byte-code generator builds a system-wide Name->BCO symbol table--  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external-                            ; return (occ_env', new_external_name) }--  | otherwise = panic "tidyTopName"-  where-    name        = idName id-    external    = isJust maybe_ref-    global      = isExternalName name-    local       = not global-    internal    = not external-    loc         = nameSrcSpan name--    old_occ     = nameOccName name-    new_occ | Just ref <- maybe_ref-            , ref /= id-            = mkOccName (occNameSpace old_occ) $-                   let-                       ref_str = occNameString (getOccName ref)-                       occ_str = occNameString old_occ-                   in-                   case occ_str of-                     '$':'w':_ -> occ_str-                        -- workers: the worker for a function already-                        -- includes the occname for its parent, so there's-                        -- no need to prepend the referrer.-                     _other | isSystemName name -> ref_str-                            | otherwise         -> ref_str ++ '_' : occ_str-                        -- If this name was system-generated, then don't bother-                        -- to retain its OccName, just use the referrer.  These-                        -- system-generated names will become "f1", "f2", etc. for-                        -- a referrer "f".-            | otherwise = old_occ--    (occ_env', occ') = tidyOccName occ_env new_occ--    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)-                    where-                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)--    mk_new_external nc = allocateGlobalBinder nc mod occ' loc-        -- If we want to externalise a currently-local name, check-        -- whether we have already assigned a unique for it.-        -- If so, use it; if not, extend the table.-        -- All this is done by allcoateGlobalBinder.-        -- This is needed when *re*-compiling a module in GHCi; we must-        -- use the same name for externally-visible things as we did before.--{--************************************************************************-*                                                                      *-\subsection{Step 2: top-level tidying}-*                                                                      *-************************************************************************--}---- TopTidyEnv: when tidying we need to know---   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.---        These may have arisen because the---        renamer read in an interface file mentioning M.$wf, say,---        and assigned it unique r77.  If, on this compilation, we've---        invented an Id whose name is $wf (but with a different unique)---        we want to rename it to have unique r77, so that we can do easy---        comparisons with stuff from the interface file------   * occ_env: The TidyOccEnv, which tells us which local occurrences---     are 'used'------   * subst_env: A Var->Var mapping that substitutes the new Var for the old--tidyTopBinds :: HscEnv-             -> Module-             -> UnfoldEnv-             -> TidyOccEnv-             -> CoreProgram-             -> IO (TidyEnv, CoreProgram)--tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds-  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env-       mkNaturalId <- lookupMkNaturalName dflags hsc_env-       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env-       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env-       let cvt_literal nt i = case nt of-             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)-             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)-             _             -> Nothing-           result      = tidy cvt_literal init_env binds-       seqBinds (snd result) `seq` return result-       -- This seqBinds avoids a spike in space usage (see #13564)-  where-    dflags = hsc_dflags hsc_env--    init_env = (init_occ_env, emptyVarEnv)--    tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env)---------------------------tidyTopBind  :: DynFlags-             -> Module-             -> (LitNumType -> Integer -> Maybe CoreExpr)-             -> UnfoldEnv-             -> TidyEnv-             -> CoreBind-             -> (TidyEnv, CoreBind)--tidyTopBind dflags this_mod cvt_literal unfold_env-            (occ_env,subst1) (NonRec bndr rhs)-  = (tidy_env2,  NonRec bndr' rhs')-  where-    Just (name',show_unfold) = lookupVarEnv unfold_env bndr-    caf_info      = hasCafRefs dflags this_mod-                               (subst1, cvt_literal)-                               (idArity bndr) rhs-    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'-                                (bndr, rhs)-    subst2        = extendVarEnv subst1 bndr bndr'-    tidy_env2     = (occ_env, subst2)--tidyTopBind dflags this_mod cvt_literal unfold_env-            (occ_env, subst1) (Rec prs)-  = (tidy_env2, Rec prs')-  where-    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)-           | (id,rhs) <- prs,-             let (name',show_unfold) =-                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id-           ]--    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')-    tidy_env2 = (occ_env, subst2)--    bndrs = map fst prs--        -- the CafInfo for a recursive group says whether *any* rhs in-        -- the group may refer indirectly to a CAF (because then, they all do).-    caf_info-        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod-                                          (subst1, cvt_literal)-                                          (idArity bndr) rhs)-             | (bndr,rhs) <- prs ] = MayHaveCafRefs-        | otherwise                = NoCafRefs--------------------------------------------------------------tidyTopPair :: DynFlags-            -> Bool  -- show unfolding-            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo-                        -- It is knot-tied: don't look at it!-            -> CafInfo-            -> Name             -- New name-            -> (Id, CoreExpr)   -- Binder and RHS before tidying-            -> (Id, CoreExpr)-        -- This function is the heart of Step 2-        -- The rec_tidy_env is the one to use for the IdInfo-        -- It's necessary because when we are dealing with a recursive-        -- group, a variable late in the group might be mentioned-        -- in the IdInfo of one early in the group--tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)-  = (bndr1, rhs1)-  where-    bndr1    = mkGlobalId details name' ty' idinfo'-    details  = idDetails bndr   -- Preserve the IdDetails-    ty'      = tidyTopType (idType bndr)-    rhs1     = tidyExpr rhs_tidy_env rhs-    idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)-                             show_unfold caf_info---- tidyTopIdInfo creates the final IdInfo for top-level--- binders.  There are two delicate pieces:------  * Arity.  After CoreTidy, this arity must not change any more.---      Indeed, CorePrep must eta expand where necessary to make---      the manifest arity equal to the claimed arity.------  * CAF info.  This must also remain valid through to code generation.---      We add the info here so that it propagates to all---      occurrences of the binders in RHSs, and hence to occurrences in---      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.---      CoreToStg makes use of this when constructing SRTs.-tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr-              -> IdInfo -> Bool -> CafInfo -> IdInfo-tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info-  | not is_external     -- For internal Ids (not externally visible)-  = vanillaIdInfo       -- we only need enough info for code generation-                        -- Arity and strictness info are enough;-                        --      c.f. CoreTidy.tidyLetBndr-        `setCafInfo`        caf_info-        `setArityInfo`      arity-        `setStrictnessInfo` final_sig-        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]-                                                 -- in CoreTidy--  | otherwise           -- Externally-visible Ids get the whole lot-  = vanillaIdInfo-        `setCafInfo`           caf_info-        `setArityInfo`         arity-        `setStrictnessInfo`    final_sig-        `setOccInfo`           robust_occ_info-        `setInlinePragInfo`    (inlinePragInfo idinfo)-        `setUnfoldingInfo`     unfold_info-                -- NB: we throw away the Rules-                -- They have already been extracted by findExternalRules-  where-    is_external = isExternalName name--    --------- OccInfo -------------    robust_occ_info = zapFragileOcc (occInfo idinfo)-    -- It's important to keep loop-breaker information-    -- when we are doing -fexpose-all-unfoldings--    --------- Strictness -------------    mb_bot_str = exprBotStrictness_maybe orig_rhs--    sig = strictnessInfo idinfo-    final_sig | not $ isTopSig sig-              = WARN( _bottom_hidden sig , ppr name ) sig-              -- try a cheap-and-cheerful bottom analyser-              | Just (_, nsig) <- mb_bot_str = nsig-              | otherwise                    = sig--    _bottom_hidden id_sig = case mb_bot_str of-                                  Nothing         -> False-                                  Just (arity, _) -> not (appIsBottom id_sig arity)--    --------- Unfolding -------------    unf_info = unfoldingInfo idinfo-    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs-                | otherwise   = minimal_unfold_info-    minimal_unfold_info = zapUnfolding unf_info-    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs-    is_bot = isBottomingSig final_sig-    -- NB: do *not* expose the worker if show_unfold is off,-    --     because that means this thing is a loop breaker or-    --     marked NOINLINE or something like that-    -- This is important: if you expose the worker for a loop-breaker-    -- then you can make the simplifier go into an infinite loop, because-    -- in effect the unfolding is exposed.  See #1709-    ---    -- You might think that if show_unfold is False, then the thing should-    -- not be w/w'd in the first place.  But a legitimate reason is this:-    --    the function returns bottom-    -- In this case, show_unfold will be false (we don't expose unfoldings-    -- for bottoming functions), but we might still have a worker/wrapper-    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs---    --------- Arity -------------    -- Usually the Id will have an accurate arity on it, because-    -- the simplifier has just run, but not always.-    -- One case I found was when the last thing the simplifier-    -- did was to let-bind a non-atomic argument and then float-    -- it to the top level. So it seems more robust just to-    -- fix it here.-    arity = exprArity orig_rhs--{--************************************************************************-*                                                                      *-           Figuring out CafInfo for an expression-*                                                                      *-************************************************************************--hasCafRefs decides whether a top-level closure can point into the dynamic heap.-We mark such things as `MayHaveCafRefs' because this information is-used to decide whether a particular closure needs to be referenced-in an SRT or not.--There are two reasons for setting MayHaveCafRefs:-        a) The RHS is a CAF: a top-level updatable thunk.-        b) The RHS refers to something that MayHaveCafRefs--Possible improvement: In an effort to keep the number of CAFs (and-hence the size of the SRTs) down, we could also look at the expression and-decide whether it requires a small bounded amount of heap, so we can ignore-it as a CAF.  In these cases however, we would need to use an additional-CAF list to keep track of non-collectable CAFs.--Note [Disgusting computation of CafRefs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We compute hasCafRefs here, because IdInfo is supposed to be finalised-after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.-So we have to *predict* the result here, which is revolting.--In particular CorePrep expands Integer and Natural literals. So in the-prediction code here we resort to applying the same expansion (cvt_literal).-There are also numerous other ways in which we can introduce inconsistencies-between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta-expansion in TidyPgm] for one such example.--Ugh! What ugliness we hath wrought.---Note [CAFfyness inconsistencies due to eta expansion in TidyPgm]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Eta expansion during CorePrep can have non-obvious negative consequences on-the CAFfyness computation done by TidyPgm (see Note [Disgusting computation of-CafRefs] in TidyPgm). This late expansion happens/happened for a few reasons:-- * CorePrep previously eta expanded unsaturated primop applications, as-   described in Note [Primop wrappers]).-- * CorePrep still does eta expand unsaturated data constructor applications.--In particular, consider the program:--    data Ty = Ty (RealWorld# -> (# RealWorld#, Int #))--    -- Is this CAFfy?-    x :: STM Int-    x = Ty (retry# @Int)--Consider whether x is CAFfy. One might be tempted to answer "no".-Afterall, f obviously has no CAF references and the application (retry#-@Int) is essentially just a variable reference at runtime.--However, when CorePrep expanded the unsaturated application of 'retry#'-it would rewrite this to--    x = \u []-       let sat = retry# @Int-       in Ty sat--This is now a CAF. Failing to handle this properly was the cause of-#16846. We fixed this by eliminating the need to eta expand primops, as-described in Note [Primop wrappers]), However we have not yet done the same for-data constructor applications.---}--type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)-  -- The env finds the Caf-ness of the Id-  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for-  -- Integer and Natural literals-  -- See Note [Disgusting computation of CafRefs]--hasCafRefs :: DynFlags -> Module-           -> CafRefEnv -> Arity -> CoreExpr-           -> CafInfo-hasCafRefs dflags this_mod (subst, cvt_literal) arity expr-  | is_caf || mentions_cafs = MayHaveCafRefs-  | otherwise               = NoCafRefs- where-  mentions_cafs   = cafRefsE expr-  is_dynamic_name = isDllName dflags this_mod-  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name-                                         cvt_literal expr)--  -- NB. we pass in the arity of the expression, which is expected-  -- to be calculated by exprArity.  This is because exprArity-  -- knows how much eta expansion is going to be done by-  -- CorePrep later on, and we don't want to duplicate that-  -- knowledge in rhsIsStatic below.--  cafRefsE :: Expr a -> Bool-  cafRefsE (Var id)            = cafRefsV id-  cafRefsE (Lit lit)           = cafRefsL lit-  cafRefsE (App f a)           = cafRefsE f || cafRefsE a-  cafRefsE (Lam _ e)           = cafRefsE e-  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e-  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)-  cafRefsE (Tick _n e)         = cafRefsE e-  cafRefsE (Cast e _co)        = cafRefsE e-  cafRefsE (Type _)            = False-  cafRefsE (Coercion _)        = False--  cafRefsEs :: [Expr a] -> Bool-  cafRefsEs []     = False-  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es--  cafRefsL :: Literal -> Bool-  -- Don't forget that mk_integer id might have Caf refs!-  -- We first need to convert the Integer into its final form, to-  -- see whether mkInteger is used. Same for LitNatural.-  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of-    Just e  -> cafRefsE e-    Nothing -> False-  cafRefsL _                = False--  cafRefsV :: Id -> Bool-  cafRefsV id-    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)-    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')-    | otherwise                         = False---{--************************************************************************-*                                                                      *-                  Old, dead, type-trimming code-*                                                                      *-************************************************************************--We used to try to "trim off" the constructors of data types that are-not exported, to reduce the size of interface files, at least without--O.  But that is not always possible: see the old Note [When we can't-trim types] below for exceptions.--Then (#7445) I realised that the TH problem arises for any data type-that we have deriving( Data ), because we can invoke-   Language.Haskell.TH.Quote.dataToExpQ-to get a TH Exp representation of a value built from that data type.-You don't even need {-# LANGUAGE TemplateHaskell #-}.--At this point I give up. The pain of trimming constructors just-doesn't seem worth the gain.  So I've dumped all the code, and am just-leaving it here at the end of the module in case something like this-is ever resurrected.---Note [When we can't trim types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea of type trimming is to export algebraic data types-abstractly (without their data constructors) when compiling without--O, unless of course they are explicitly exported by the user.--We always export synonyms, because they can be mentioned in the type-of an exported Id.  We could do a full dependency analysis starting-from the explicit exports, but that's quite painful, and not done for-now.--But there are some times we can't do that, indicated by the 'no_trim_types' flag.--First, Template Haskell.  Consider (#2386) this-        module M(T, makeOne) where-          data T = Yay String-          makeOne = [| Yay "Yep" |]-Notice that T is exported abstractly, but makeOne effectively exports it too!-A module that splices in $(makeOne) will then look for a declaration of Yay,-so it'd better be there.  Hence, brutally but simply, we switch off type-constructor trimming if TH is enabled in this module.--Second, data kinds.  Consider (#5912)-     {-# LANGUAGE DataKinds #-}-     module M() where-     data UnaryTypeC a = UnaryDataC a-     type Bug = 'UnaryDataC-We always export synonyms, so Bug is exposed, and that means that-UnaryTypeC must be too, even though it's not explicitly exported.  In-effect, DataKinds means that we'd need to do a full dependency analysis-to see what data constructors are mentioned.  But we don't do that yet.--In these two cases we just switch off type trimming altogether.--mustExposeTyCon :: Bool         -- Type-trimming flag-                -> NameSet      -- Exports-                -> TyCon        -- The tycon-                -> Bool         -- Can its rep be hidden?--- We are compiling without -O, and thus trying to write as little as--- possible into the interface file.  But we must expose the details of--- any data types whose constructors or fields are exported-mustExposeTyCon no_trim_types exports tc-  | no_trim_types               -- See Note [When we can't trim types]-  = True--  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to-                                -- figure out whether it was mentioned in the type-                                -- of any other exported thing)-  = True--  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors-  = True                        -- won't lead to the need for further exposure--  | isFamilyTyCon tc            -- Open type family-  = True--  -- Below here we just have data/newtype decls or family instances--  | null data_cons              -- Ditto if there are no data constructors-  = True                        -- (NB: empty data types do not count as enumerations-                                -- see Note [Enumeration types] in TyCon--  | any exported_con data_cons  -- Expose rep if any datacon or field is exported-  = True--  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))-  = True   -- Expose the rep for newtypes if the rep is an FFI type.-           -- For a very annoying reason.  'Foreign import' is meant to-           -- be able to look through newtypes transparently, but it-           -- can only do that if it can "see" the newtype representation--  | otherwise-  = False-  where-    data_cons = tyConDataCons tc-    exported_con con = any (`elemNameSet` exports)-                           (dataConName con : dataConFieldLabels con)--}
compiler/nativeGen/AsmCodeGen.hs view
@@ -13,6 +13,8 @@ {-# LANGUAGE UnboxedTuples #-} #endif +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module AsmCodeGen (                     -- * Module entry point                     nativeCodeGen@@ -67,18 +69,18 @@ import NCGMonad import CFG import Dwarf-import Debug+import GHC.Cmm.DebugBlock -import BlockId+import GHC.Cmm.BlockId import GHC.StgToCmm.CgUtils ( fixStgRegisters )-import Cmm-import CmmUtils-import Hoopl.Collections-import Hoopl.Label-import Hoopl.Block-import CmmOpt           ( cmmMachOpFold )-import PprCmm-import CLabel+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Opt           ( cmmMachOpFold )+import GHC.Cmm.Ppr+import GHC.Cmm.CLabel  import UniqFM import UniqSupply@@ -826,7 +828,7 @@     -- relevant register writes within a procedure.     --     -- However, the only unwinding information that we care about in GHC is for-    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind+    -- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind     -- information at the beginning of every block means that there is no need     -- to perform this sort of push-down.     mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
compiler/nativeGen/BlockLayout.hs view
@@ -20,10 +20,10 @@ import NCGMonad import CFG -import BlockId-import Cmm-import Hoopl.Collections-import Hoopl.Label+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label  import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg) import UniqFM@@ -35,7 +35,7 @@ import Maybes  -- DEBUGGING ONLY---import Debug+--import GHC.Cmm.DebugBlock --import Debug.Trace import ListSetOps (removeDups) @@ -342,7 +342,7 @@ -- We have the chains (A-B-C-D) and (E-F) and an Edge C->E. -- -- While placing the latter after the former doesn't result in sequential--- control flow it is still benefical. As block C and E might end+-- control flow it is still beneficial. As block C and E might end -- up in the same cache line. -- -- So we place these chains next to each other even if we can't fuse them.@@ -374,7 +374,7 @@                       -- were used to fuse chains and as such no longer need to be                       -- considered. combineNeighbourhood edges chains-    = -- pprTraceIt "Neigbours" $+    = -- pprTraceIt "Neighbours" $     --   pprTrace "combineNeighbours" (ppr edges) $       applyEdges edges endFrontier startFrontier (Set.empty)     where@@ -718,8 +718,10 @@             = [masterChain]             | (rest,entry) <- breakChainAt entry masterChain             = [entry,rest]+#if __GLASGOW_HASKELL__ <= 810             | otherwise = pprPanic "Entry point eliminated" $                             ppr masterChain+#endif          blockList             = ASSERT(noDups [masterChain])@@ -740,7 +742,7 @@             --pprTraceIt "placedBlocks" $             -- ++ [] is stil kinda expensive             if null unplaced then blockList else blockList ++ unplaced-        getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap+        getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input         ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
compiler/nativeGen/CFG.hs view
@@ -46,15 +46,15 @@  import GhcPrelude -import BlockId-import Cmm+import GHC.Cmm.BlockId+import GHC.Cmm as Cmm -import CmmUtils-import CmmSwitch-import Hoopl.Collections-import Hoopl.Label-import Hoopl.Block-import qualified Hoopl.Graph as G+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Block+import qualified GHC.Cmm.Dataflow.Graph as G  import Util import Digraph@@ -74,11 +74,10 @@  import Outputable -- DEBUGGING ONLY---import Debug--- import Debug.Trace+--import GHC.Cmm.DebugBlock --import OrdList---import Debug.Trace-import PprCmm () -- For Outputable instances+--import GHC.Cmm.DebugBlock.Trace+import GHC.Cmm.Ppr () -- For Outputable instances import qualified DynFlags as D  import Data.List@@ -250,7 +249,7 @@ {- Note [Updating the CFG during shortcutting]  See Note [What is shortcutting] in the control flow optimization-code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting.+code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting.  In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs) This means we remove blocks containing only one jump from the code@@ -291,7 +290,7 @@ Then it redirects all jump instructions to these blocks using the built up mapping. This function (shortcutWeightMap) takes the same mapping and-applies the mapping to the CFG in the way layed out above.+applies the mapping to the CFG in the way laid out above.  -} shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG@@ -575,7 +574,7 @@     so have a larger number of successors. So without more information     we can only say that each individual successor is unlikely to be     jumped to and we rank them accordingly.-  * Calls - We currently ignore calls completly:+  * Calls - We currently ignore calls completely:         * By the time we return from a call there is a good chance           that the address we return to has already been evicted from           cache eliminating a main advantage sequential placement brings.@@ -648,7 +647,7 @@         (CmmCall { cml_cont = Nothing })   -> []         other ->             panic "Foo" $-            ASSERT2(False, ppr "Unkown successor cause:" <>+            ASSERT2(False, ppr "Unknown successor cause:" <>               (ppr branch <+> text "=>" <> ppr (G.successors other)))             map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other       where@@ -959,10 +958,10 @@      vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int     blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId-    -- Map from blockId to indicies starting at zero+    -- Map from blockId to indices starting at zero     toVertex :: BlockId -> Int     toVertex   blockId  = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping-    -- Map from indicies starting at zero to blockIds+    -- Map from indices starting at zero to blockIds     fromVertex :: Int -> BlockId     fromVertex vertex   = blockMapping ! vertex @@ -990,13 +989,13 @@  TODO: * The paper containers more benchmarks which should be implemented.-* If we turn the likelyhood on if/else branches into a probability+* If we turn the likelihood on if/else branches into a probability   instead of true/false we could implement this as a Cmm pass.   + The complete Cmm code still exists and can be accessed by the heuristics   + There is no chance of register allocation/codegen inserting branches/blocks   + making the TransitionSource info wrong.   + potential to use this information in CmmPasses.-  - Requires refactoring of all the code relying on the binary nature of likelyhood.+  - Requires refactoring of all the code relying on the binary nature of likelihood.   - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG. -} @@ -1060,7 +1059,7 @@                 heuristics = map ($ ((s1,s1_info),(s2,s2_info)))                             [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts                             , shPredicts, rhPredicts]-                -- Apply result of a heuristic. Argument is the likelyhood+                -- Apply result of a heuristic. Argument is the likelihood                 -- predicted for s1.                 applyHeuristic :: CFG -> Maybe Prob -> CFG                 applyHeuristic cfg Nothing = cfg@@ -1101,7 +1100,7 @@         (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors          -- Heuristics return nothing if they don't say anything about this branch-        -- or Just (prob_s1) where prob_s1 is the likelyhood for s1 to be the+        -- or Just (prob_s1) where prob_s1 is the likelihood for s1 to be the         -- taken branch. s1 is the branch in the true case.          -- Loop exit heuristic.
compiler/nativeGen/CPrim.hs view
@@ -16,8 +16,8 @@  import GhcPrelude -import CmmType-import CmmMachOp+import GHC.Cmm.Type+import GHC.Cmm.MachOp import Outputable  popCntLabel :: Width -> String
compiler/nativeGen/Dwarf.hs view
@@ -4,11 +4,11 @@  import GhcPrelude -import CLabel-import CmmExpr         ( GlobalReg(..) )+import GHC.Cmm.CLabel+import GHC.Cmm.Expr    ( GlobalReg(..) ) import Config          ( cProjectName, cProjectVersion ) import CoreSyn         ( Tickish(..) )-import Debug+import GHC.Cmm.DebugBlock import DynFlags import Module import Outputable@@ -28,8 +28,8 @@ import System.FilePath import System.Directory ( getCurrentDirectory ) -import qualified Hoopl.Label as H-import qualified Hoopl.Collections as H+import qualified GHC.Cmm.Dataflow.Label as H+import qualified GHC.Cmm.Dataflow.Collections as H  -- | Generate DWARF/debug information dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
compiler/nativeGen/Dwarf/Types.hs view
@@ -24,9 +24,9 @@  import GhcPrelude -import Debug-import CLabel-import CmmExpr         ( GlobalReg(..) )+import GHC.Cmm.DebugBlock+import GHC.Cmm.CLabel+import GHC.Cmm.Expr         ( GlobalReg(..) ) import Encoding import FastString import Outputable@@ -284,7 +284,7 @@   ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds  -- | Header for the @.debug_frame@ section. Here we emit the "Common--- Information Entry" record that etablishes general call frame+-- Information Entry" record that establishes general call frame -- parameters and the default stack layout. pprDwarfFrame :: DwarfFrame -> SDoc pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
compiler/nativeGen/Format.hs view
@@ -22,7 +22,7 @@  import GhcPrelude -import Cmm+import GHC.Cmm import Outputable  -- It looks very like the old MachRep, but it's now of purely local
compiler/nativeGen/Instruction.hs view
@@ -18,11 +18,11 @@  import Reg -import BlockId-import Hoopl.Collections-import Hoopl.Label+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import DynFlags-import Cmm hiding (topInfoTable)+import GHC.Cmm hiding (topInfoTable) import GHC.Platform  -- | Holds a list of source and destination registers used by a
compiler/nativeGen/NCGMonad.hs view
@@ -49,11 +49,11 @@ import Format import TargetReg -import BlockId-import Hoopl.Collections-import Hoopl.Label-import CLabel           ( CLabel )-import Debug+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel           ( CLabel )+import GHC.Cmm.DebugBlock import FastString       ( FastString ) import UniqFM import UniqSupply@@ -65,7 +65,7 @@  import Instruction import Outputable (SDoc, pprPanic, ppr)-import Cmm (RawCmmDecl, CmmStatics)+import GHC.Cmm (RawCmmDecl, CmmStatics) import CFG  data NcgImpl statics instr jumpDest = NcgImpl {@@ -226,7 +226,7 @@           addWeightEdge between old weight .           delEdge from old $ m         | otherwise-        = pprPanic "Faild to update cfg: Untracked edge" (ppr (from,to))+        = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to))   -- | Place `succ` after `block` and change any edges
compiler/nativeGen/PIC.hs view
@@ -60,14 +60,14 @@ import NCGMonad  -import Hoopl.Collections-import Cmm-import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,                           mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),                           dynamicLinkerLabelInfo, mkPicBaseLabel,                           labelDynamic, externallyVisibleCLabel ) -import CLabel           ( mkForeignLabel )+import GHC.Cmm.CLabel           ( mkForeignLabel )   import BasicTypes@@ -217,7 +217,7 @@  -- Windows -- In Windows speak, a "module" is a set of objects linked into the--- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs).+-- same Portable Executable (PE) file. (both .exe and .dll files are PEs). -- -- If we're compiling a multi-module program then symbols from other modules -- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the
compiler/nativeGen/PPC/CodeGen.hs view
@@ -42,14 +42,14 @@ import GHC.Platform  -- Our intermediate code:-import BlockId-import PprCmm           ( pprExpr )-import Cmm-import CmmUtils-import CmmSwitch-import CLabel-import Hoopl.Block-import Hoopl.Graph+import GHC.Cmm.BlockId+import GHC.Cmm.Ppr           ( pprExpr )+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph  -- The rest: import OrdList@@ -425,7 +425,7 @@ getRegister' dflags tree@(CmmRegOff _ _)   = getRegister' dflags (mangleIndexTree dflags tree) -    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:+    -- for 32-bit architectures, support some 64 -> 32 bit conversions:     -- TO_W_(x), TO_W_(x >> 32)  getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)
compiler/nativeGen/PPC/Instr.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language@@ -33,14 +35,14 @@ import Reg  import GHC.Platform.Regs-import BlockId-import Hoopl.Collections-import Hoopl.Label+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import DynFlags-import Cmm-import CmmInfo+import GHC.Cmm+import GHC.Cmm.Info import FastString-import CLabel+import GHC.Cmm.CLabel import Outputable import GHC.Platform import UniqFM (listToUFM, lookupUFM)
compiler/nativeGen/PPC/Ppr.hs view
@@ -21,13 +21,13 @@ import RegClass import TargetReg -import Cmm hiding (topInfoTable)-import Hoopl.Collections-import Hoopl.Label+import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label -import BlockId-import CLabel-import PprCmmExpr () -- For Outputable instances+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Ppr.Expr () -- For Outputable instances  import Unique                ( pprUniqueAlways, getUnique ) import GHC.Platform@@ -846,7 +846,7 @@             -- Note: we're using fcmpu, not fcmpo             -- The difference is with fcmpo, compare with NaN is an invalid operation.             -- We don't handle invalid fp ops, so we don't care.-            -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for+            -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for             -- better portability since some non-GNU assembler (such as             -- IBM's `as`) tend not to support the symbolic register name cr0.             -- This matches the syntax that GCC seems to emit for PPC targets.
compiler/nativeGen/PPC/RegInfo.hs view
@@ -23,9 +23,9 @@  import PPC.Instr -import BlockId-import Cmm-import CLabel+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.CLabel  import Unique import Outputable (ppr, text, Outputable, (<>))
compiler/nativeGen/PPC/Regs.hs view
@@ -55,8 +55,8 @@ import RegClass import Format -import Cmm-import CLabel           ( CLabel )+import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel ) import Unique  import GHC.Platform.Regs
compiler/nativeGen/PprBase.hs view
@@ -23,8 +23,8 @@ import GhcPrelude  import AsmUtils-import CLabel-import Cmm+import GHC.Cmm.CLabel+import GHC.Cmm import DynFlags import FastString import Outputable
− compiler/nativeGen/Reg.hs 
@@ -1,241 +0,0 @@--- | An architecture independent description of a register.---      This needs to stay architecture independent because it is used---      by NCGMonad and the register allocators, which are shared---      by all architectures.----module Reg (-        RegNo,-        Reg(..),-        regPair,-        regSingle,-        isRealReg,      takeRealReg,-        isVirtualReg,   takeVirtualReg,--        VirtualReg(..),-        renameVirtualReg,-        classOfVirtualReg,-        getHiVirtualRegFromLo,-        getHiVRegFromLo,--        RealReg(..),-        regNosOfRealReg,-        realRegsAlias,--        liftPatchFnToRegReg-)--where--import GhcPrelude--import Outputable-import Unique-import RegClass-import Data.List---- | An identifier for a primitive real machine register.-type RegNo-        = Int---- VirtualRegs are virtual registers.  The register allocator will---      eventually have to map them into RealRegs, or into spill slots.------      VirtualRegs are allocated on the fly, usually to represent a single---      value in the abstract assembly code (i.e. dynamic registers are---      usually single assignment).------      The  single assignment restriction isn't necessary to get correct code,---      although a better register allocation will result if single---      assignment is used -- because the allocator maps a VirtualReg into---      a single RealReg, even if the VirtualReg has multiple live ranges.------      Virtual regs can be of either class, so that info is attached.----data VirtualReg-        = VirtualRegI  {-# UNPACK #-} !Unique-        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register-        | VirtualRegF  {-# UNPACK #-} !Unique-        | VirtualRegD  {-# UNPACK #-} !Unique--        deriving (Eq, Show)---- This is laborious, but necessary. We can't derive Ord because--- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the--- implementation. See Note [No Ord for Unique]--- This is non-deterministic but we do not currently support deterministic--- code-generation. See Note [Unique Determinism and code generation]-instance Ord VirtualReg where-  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b-  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b-  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b-  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b--  compare VirtualRegI{} _ = LT-  compare _ VirtualRegI{} = GT-  compare VirtualRegHi{} _ = LT-  compare _ VirtualRegHi{} = GT-  compare VirtualRegF{} _ = LT-  compare _ VirtualRegF{} = GT----instance Uniquable VirtualReg where-        getUnique reg-         = case reg of-                VirtualRegI u   -> u-                VirtualRegHi u  -> u-                VirtualRegF u   -> u-                VirtualRegD u   -> u--instance Outputable VirtualReg where-        ppr reg-         = case reg of-                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u-                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u-                -- this code is kinda wrong on x86-                -- because float and double occupy the same register set-                -- namely SSE2 register xmm0 .. xmm15-                VirtualRegF  u  -> text "%vFloat_"   <> pprUniqueAlways u-                VirtualRegD  u  -> text "%vDouble_"   <> pprUniqueAlways u----renameVirtualReg :: Unique -> VirtualReg -> VirtualReg-renameVirtualReg u r- = case r of-        VirtualRegI _   -> VirtualRegI  u-        VirtualRegHi _  -> VirtualRegHi u-        VirtualRegF _   -> VirtualRegF  u-        VirtualRegD _   -> VirtualRegD  u---classOfVirtualReg :: VirtualReg -> RegClass-classOfVirtualReg vr- = case vr of-        VirtualRegI{}   -> RcInteger-        VirtualRegHi{}  -> RcInteger-        VirtualRegF{}   -> RcFloat-        VirtualRegD{}   -> RcDouble------ Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform--- when supplied with the vreg for the lower-half of the quantity.--- (NB. Not reversible).-getHiVirtualRegFromLo :: VirtualReg -> VirtualReg-getHiVirtualRegFromLo reg- = case reg of-        -- makes a pseudo-unique with tag 'H'-        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')-        _               -> panic "Reg.getHiVirtualRegFromLo"--getHiVRegFromLo :: Reg -> Reg-getHiVRegFromLo reg- = case reg of-        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)-        RegReal _       -> panic "Reg.getHiVRegFromLo"------------------------------------------------------------------------------------------ | RealRegs are machine regs which are available for allocation, in---      the usual way.  We know what class they are, because that's part of---      the processor's architecture.------      RealRegPairs are pairs of real registers that are allocated together---      to hold a larger value, such as with Double regs on SPARC.----data RealReg-        = RealRegSingle {-# UNPACK #-} !RegNo-        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo-        deriving (Eq, Show, Ord)--instance Uniquable RealReg where-        getUnique reg-         = case reg of-                RealRegSingle i         -> mkRegSingleUnique i-                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)--instance Outputable RealReg where-        ppr reg-         = case reg of-                RealRegSingle i         -> text "%r"  <> int i-                RealRegPair r1 r2       -> text "%r(" <> int r1-                                           <> vbar <> int r2 <> text ")"--regNosOfRealReg :: RealReg -> [RegNo]-regNosOfRealReg rr- = case rr of-        RealRegSingle r1        -> [r1]-        RealRegPair   r1 r2     -> [r1, r2]---realRegsAlias :: RealReg -> RealReg -> Bool-realRegsAlias rr1 rr2-        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)------------------------------------------------------------------------------------- | A register, either virtual or real-data Reg-        = RegVirtual !VirtualReg-        | RegReal    !RealReg-        deriving (Eq, Ord)--regSingle :: RegNo -> Reg-regSingle regNo         = RegReal $ RealRegSingle regNo--regPair :: RegNo -> RegNo -> Reg-regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2----- We like to have Uniques for Reg so that we can make UniqFM and UniqSets--- in the register allocator.-instance Uniquable Reg where-        getUnique reg-         = case reg of-                RegVirtual vr   -> getUnique vr-                RegReal    rr   -> getUnique rr---- | Print a reg in a generic manner---      If you want the architecture specific names, then use the pprReg---      function from the appropriate Ppr module.-instance Outputable Reg where-        ppr reg-         = case reg of-                RegVirtual vr   -> ppr vr-                RegReal    rr   -> ppr rr---isRealReg :: Reg -> Bool-isRealReg reg- = case reg of-        RegReal _       -> True-        RegVirtual _    -> False--takeRealReg :: Reg -> Maybe RealReg-takeRealReg reg- = case reg of-        RegReal rr      -> Just rr-        _               -> Nothing---isVirtualReg :: Reg -> Bool-isVirtualReg reg- = case reg of-        RegReal _       -> False-        RegVirtual _    -> True--takeVirtualReg :: Reg -> Maybe VirtualReg-takeVirtualReg reg- = case reg of-        RegReal _       -> Nothing-        RegVirtual vr   -> Just vr----- | The patch function supplied by the allocator maps VirtualReg to RealReg---      regs, but sometimes we want to apply it to plain old Reg.----liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)-liftPatchFnToRegReg patchF reg- = case reg of-        RegVirtual vr   -> RegReal (patchF vr)-        RegReal _       -> reg
compiler/nativeGen/RegAlloc/Graph/Coalesce.hs view
@@ -9,7 +9,7 @@ import Instruction import Reg -import Cmm+import GHC.Cmm import Bag import Digraph import UniqFM
compiler/nativeGen/RegAlloc/Graph/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}  -- | Graph coloring register allocator.@@ -83,7 +84,7 @@  -- | Perform solver iterations for the graph coloring allocator. -----   We extract a register confict graph from the provided cmm code,+--   We extract a register conflict graph from the provided cmm code, --   and try to colour it. If that works then we use the solution rewrite --   the code with real hregs. If coloring doesn't work we add spill code --   and try to colour it again. After `maxSpinCount` iterations we give up.@@ -376,8 +377,10 @@         , RegReal _             <- r2         = graph +#if __GLASGOW_HASKELL__ <= 810         | otherwise         = panic "graphAddCoalesce"+#endif   -- | Patch registers in code using the reg -> reg mapping in this graph.
compiler/nativeGen/RegAlloc/Graph/Spill.hs view
@@ -12,9 +12,9 @@ import RegAlloc.Liveness import Instruction import Reg-import Cmm hiding (RegSet)-import BlockId-import Hoopl.Collections+import GHC.Cmm hiding (RegSet)+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections  import MonadUtils import State
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  -- | Clean out unneeded spill\/reload instructions. --@@ -34,15 +35,15 @@ import Instruction import Reg -import BlockId-import Cmm+import GHC.Cmm.BlockId+import GHC.Cmm import UniqSet import UniqFM import Unique import State import Outputable import GHC.Platform-import Hoopl.Collections+import GHC.Cmm.Dataflow.Collections  import Data.List import Data.Maybe@@ -393,9 +394,11 @@                  cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs +#if __GLASGOW_HASKELL__ <= 810         -- some other instruction         | otherwise         = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs+#endif   -- | Combine the associations from all the inward control flow edges.@@ -611,4 +614,3 @@ intersectAssoc :: Assoc a -> Assoc a -> Assoc a intersectAssoc a b         = intersectUFM_C (intersectUniqSets) a b-
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs view
@@ -22,9 +22,9 @@  import GraphBase -import Hoopl.Collections (mapLookup)-import Hoopl.Label-import Cmm+import GHC.Cmm.Dataflow.Collections (mapLookup)+import GHC.Cmm.Dataflow.Label+import GHC.Cmm import UniqFM import UniqSet import Digraph          (flattenSCCs)@@ -38,7 +38,7 @@ import Control.Monad (join)  --- | Records the expected cost to spill some regster.+-- | Records the expected cost to spill some register. type SpillCostRecord  =      ( VirtualReg    -- register name         , Int           -- number of writes to this reg
compiler/nativeGen/RegAlloc/Graph/Stats.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- | Carries interesting info for debugging / profiling of the --   graph coloring register allocator. module RegAlloc.Graph.Stats (
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs view
@@ -26,7 +26,7 @@ --      This gets hammered by scanGraph during register allocation, --      so needs to be fairly efficient. -----      NOTE:   This only works for arcitectures with just RcInteger and RcDouble+--      NOTE:   This only works for architectures with just RcInteger and RcDouble --              (which are disjoint) ie. x86, x86_64 and ppc -- --      The number of allocatable regs is hard coded in here so we can do
compiler/nativeGen/RegAlloc/Linear/Base.hs view
@@ -28,7 +28,7 @@ import Unique import UniqFM import UniqSupply-import BlockId+import GHC.Cmm.BlockId   -- | Used to store the register assignment on entry to a basic block.
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Handles joining of a jump instruction to its targets. @@ -18,8 +19,8 @@ import Instruction import Reg -import BlockId-import Hoopl.Collections+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections import Digraph import DynFlags import Outputable
compiler/nativeGen/RegAlloc/Linear/Main.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ ----------------------------------------------------------------------------- -- -- The register allocator@@ -119,9 +121,9 @@ import Instruction import Reg -import BlockId-import Hoopl.Collections-import Cmm hiding (RegSet)+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm hiding (RegSet)  import Digraph import DynFlags@@ -777,7 +779,7 @@                    -- NOTE: if the input to the NCG contains some                    -- unreachable blocks with junk code, this panic                    -- might be triggered.  Make sure you only feed-                   -- sensible code into the NCG.  In CmmPipeline we+                   -- sensible code into the NCG.  In GHC.Cmm.Pipeline we                    -- call removeUnreachableBlocks at the end for this                    -- reason.
compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  -- | Free regs map for SPARC module RegAlloc.Linear.SPARC.FreeRegs@@ -55,7 +56,9 @@         | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0         | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32         | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32+#if __GLASGOW_HASKELL__ <= 810         | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)+#endif         where                 go _    _      0    _                         = []@@ -184,4 +187,3 @@         ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"         ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"         ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"-
compiler/nativeGen/RegAlloc/Linear/State.hs view
@@ -44,7 +44,7 @@ import RegAlloc.Liveness import Instruction import Reg-import BlockId+import GHC.Cmm.BlockId  import DynFlags import Unique
compiler/nativeGen/RegAlloc/Liveness.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ ----------------------------------------------------------------------------- -- -- The register liveness determinator@@ -40,11 +42,11 @@ import Reg import Instruction -import BlockId+import GHC.Cmm.BlockId import CFG-import Hoopl.Collections-import Hoopl.Label-import Cmm hiding (RegSet, emptyRegSet)+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm hiding (RegSet, emptyRegSet)  import Digraph import DynFlags
− compiler/nativeGen/RegClass.hs 
@@ -1,32 +0,0 @@--- | An architecture independent description of a register's class.-module RegClass-        ( RegClass (..) )--where--import GhcPrelude--import  Outputable-import  Unique----- | The class of a register.---      Used in the register allocator.---      We treat all registers in a class as being interchangeable.----data RegClass-        = RcInteger-        | RcFloat-        | RcDouble-        deriving Eq---instance Uniquable RegClass where-    getUnique RcInteger = mkRegClassUnique 0-    getUnique RcFloat   = mkRegClassUnique 1-    getUnique RcDouble  = mkRegClassUnique 2--instance Outputable RegClass where-    ppr RcInteger       = Outputable.text "I"-    ppr RcFloat         = Outputable.text "F"-    ppr RcDouble        = Outputable.text "D"
compiler/nativeGen/SPARC/CodeGen.hs view
@@ -39,15 +39,15 @@ import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat )  -- Our intermediate code:-import BlockId-import Cmm-import CmmUtils-import CmmSwitch-import Hoopl.Block-import Hoopl.Graph+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph import PIC import Reg-import CLabel+import GHC.Cmm.CLabel import CPrim  -- The rest:
compiler/nativeGen/SPARC/CodeGen/Amode.hs view
@@ -16,7 +16,7 @@ import NCGMonad import Format -import Cmm+import GHC.Cmm  import OrdList
compiler/nativeGen/SPARC/CodeGen/Base.hs view
@@ -24,8 +24,8 @@  import GHC.Platform.Regs import DynFlags-import Cmm-import PprCmmExpr () -- For Outputable instances+import GHC.Cmm+import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Platform  import Outputable
compiler/nativeGen/SPARC/CodeGen/CondCode.hs view
@@ -18,7 +18,7 @@ import NCGMonad import Format -import Cmm+import GHC.Cmm  import OrdList import Outputable
compiler/nativeGen/SPARC/CodeGen/Expand.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ -- | Expand out synthetic instructions into single machine instrs. module SPARC.CodeGen.Expand (         expandTop@@ -14,7 +16,7 @@ import Instruction import Reg import Format-import Cmm+import GHC.Cmm   import Outputable
compiler/nativeGen/SPARC/CodeGen/Gen32.hs view
@@ -23,7 +23,7 @@ import Format import Reg -import Cmm+import GHC.Cmm  import Control.Monad (liftM) import DynFlags
compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot view
@@ -10,7 +10,7 @@ import NCGMonad import Reg -import Cmm+import GHC.Cmm  getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock) getRegister :: CmmExpr -> NatM Register
compiler/nativeGen/SPARC/CodeGen/Gen64.hs view
@@ -22,7 +22,7 @@ import Format import Reg -import Cmm+import GHC.Cmm  import DynFlags import OrdList
compiler/nativeGen/SPARC/CodeGen/Sanity.hs view
@@ -12,7 +12,7 @@ import SPARC.Ppr        () -- For Outputable instances import Instruction -import Cmm+import GHC.Cmm  import Outputable
compiler/nativeGen/SPARC/Imm.hs view
@@ -9,8 +9,8 @@  import GhcPrelude -import Cmm-import CLabel+import GHC.Cmm+import GHC.Cmm.CLabel  import Outputable
compiler/nativeGen/SPARC/Instr.hs view
@@ -38,11 +38,11 @@ import Reg import Format -import CLabel+import GHC.Cmm.CLabel import GHC.Platform.Regs-import BlockId+import GHC.Cmm.BlockId import DynFlags-import Cmm+import GHC.Cmm import FastString import Outputable import GHC.Platform
compiler/nativeGen/SPARC/Ppr.hs view
@@ -37,12 +37,12 @@ import Format import PprBase -import Cmm hiding (topInfoTable)-import PprCmm() -- For Outputable instances-import BlockId-import CLabel-import Hoopl.Label-import Hoopl.Collections+import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.Ppr() -- For Outputable instances+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Collections  import Unique           ( pprUniqueAlways ) import Outputable
compiler/nativeGen/SPARC/ShortcutJump.hs view
@@ -13,9 +13,9 @@ import SPARC.Instr import SPARC.Imm -import CLabel-import BlockId-import Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.BlockId+import GHC.Cmm  import Panic import Outputable
compiler/nativeGen/X86/CodeGen.hs view
@@ -9,6 +9,8 @@ {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} #endif +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection)@@ -44,7 +46,7 @@  import GHC.Platform.Regs import CPrim-import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable+import GHC.Cmm.DebugBlock            ( DebugBlock(..), UnwindPoint(..), UnwindTable                         , UnwindExpr(UwReg), toUnwindExpr ) import Instruction import PIC@@ -59,16 +61,16 @@  -- Our intermediate code: import BasicTypes-import BlockId+import GHC.Cmm.BlockId import Module           ( primUnitId )-import CmmUtils-import CmmSwitch-import Cmm-import Hoopl.Block-import Hoopl.Collections-import Hoopl.Graph-import Hoopl.Label-import CLabel+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel import CoreSyn          ( Tickish(..) ) import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) @@ -360,7 +362,7 @@       CmmBranch id          -> return $ genBranch id        --We try to arrange blocks such that the likely branch is the fallthrough-      --in CmmContFlowOpt. So we can assume the condition is likely false here.+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.       CmmCondBranch arg true false _ -> genCondBranch bid true false arg       CmmSwitch arg ids -> do dflags <- getDynFlags                               genSwitch dflags arg ids@@ -1333,7 +1335,7 @@ x86_complex_amode base index shift offset   = do (x_reg, x_code) <- getNonClobberedReg base         -- x must be in a temp, because it has to stay live over y_code-        -- we could compre x_reg and y_reg and do something better here...+        -- we could compare x_reg and y_reg and do something better here...        (y_reg, y_code) <- getSomeReg index        let            code = x_code `appOL` y_code
compiler/nativeGen/X86/Instr.hs view
@@ -26,22 +26,22 @@ import Reg import TargetReg -import BlockId-import Hoopl.Collections-import Hoopl.Label+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs-import Cmm+import GHC.Cmm import FastString import Outputable import GHC.Platform  import BasicTypes       (Alignment)-import CLabel+import GHC.Cmm.CLabel import DynFlags import UniqSet import Unique import UniqSupply-import Debug (UnwindTable)+import GHC.Cmm.DebugBlock (UnwindTable)  import Control.Monad import Data.Maybe       (fromMaybe)
compiler/nativeGen/X86/Ppr.hs view
@@ -33,13 +33,13 @@ import PprBase  -import Hoopl.Collections-import Hoopl.Label+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import BasicTypes       (Alignment, mkAlignment, alignmentBytes) import DynFlags-import Cmm              hiding (topInfoTable)-import BlockId-import CLabel+import GHC.Cmm              hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel import Unique           ( pprUniqueAlways ) import GHC.Platform import FastString
compiler/nativeGen/X86/Regs.hs view
@@ -55,8 +55,8 @@ import Reg import RegClass -import Cmm-import CLabel           ( CLabel )+import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel ) import DynFlags import Outputable import GHC.Platform
compiler/prelude/PrelInfo.hs view
@@ -100,7 +100,7 @@   checker sees if the Name is wired in before looking up the name in   the type environment. -* MkIface prunes out wired-in things before putting them in an interface file.+* GHC.Iface.Utils prunes out wired-in things before putting them in an interface file.   So interface files never contain wired-in things. -} @@ -205,7 +205,7 @@ -- GHCi's ':info' command. lookupKnownNameInfo :: Name -> SDoc lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of-    -- If we do find a doc, we add comment delimeters to make the output+    -- If we do find a doc, we add comment delimiters to make the output     -- of ':info' valid Haskell.     Nothing  -> empty     Just doc -> vcat [text "{-", doc, text "-}"]
compiler/prelude/THNames.hs view
@@ -146,18 +146,18 @@     derivClauseName,      -- The type classes-    liftClassName,+    liftClassName, quoteClassName,      -- And the tycons-    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,-    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,-    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,-    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,-    typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,-    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,-    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,-    roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,-    overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,+    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,+    expQTyConName, fieldExpTyConName, predTyConName,+    stmtTyConName,  decsTyConName, conTyConName, bangTypeTyConName,+    varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,+    typeTyConName, tyVarBndrTyConName, clauseTyConName,+    patQTyConName, funDepTyConName, decsQTyConName,+    ruleBndrTyConName, tySynEqnTyConName,+    roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,+    overlapTyConName, derivClauseTyConName, derivStrategyTyConName,      -- Quasiquoting     quoteDecName, quoteTypeName, quoteExpName, quotePatName]@@ -183,10 +183,13 @@ liftClassName :: Name liftClassName = thCls (fsLit "Lift") liftClassKey +quoteClassName :: Name+quoteClassName = thCls (fsLit "Quote") quoteClassKey+ qTyConName, nameTyConName, fieldExpTyConName, patTyConName,     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,     matchTyConName, clauseTyConName, funDepTyConName, predTyConName,-    tExpTyConName, injAnnTyConName, overlapTyConName :: Name+    tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName :: Name qTyConName             = thTc (fsLit "Q")              qTyConKey nameTyConName          = thTc (fsLit "Name")           nameTyConKey fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey@@ -194,6 +197,7 @@ fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey expTyConName           = thTc (fsLit "Exp")            expTyConKey decTyConName           = thTc (fsLit "Dec")            decTyConKey+decsTyConName          = libTc (fsLit "Decs")           decsTyConKey typeTyConName          = thTc (fsLit "Type")           typeTyConKey matchTyConName         = thTc (fsLit "Match")          matchTyConKey clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey@@ -546,34 +550,30 @@ newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey -matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,-    decQTyConName, conQTyConName, bangTypeQTyConName,-    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,-    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,-    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,-    derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,-    derivStrategyQTyConName :: Name-matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey-clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey+patQTyConName, expQTyConName, stmtTyConName,+    conTyConName, bangTypeTyConName,+    varBangTypeTyConName, typeQTyConName,+    decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,+    derivClauseTyConName, kindTyConName, tyVarBndrTyConName,+    derivStrategyTyConName :: Name+-- These are only used for the types of top-level splices expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey-stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey-decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]-conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey-bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey-varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey-fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey-fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey-predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey-ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey-tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey++-- These are used in DsMeta but always wrapped in a type variable+stmtTyConName           = thTc (fsLit "Stmt")            stmtTyConKey+conTyConName            = thTc (fsLit "Con")             conTyConKey+bangTypeTyConName       = thTc (fsLit "BangType")      bangTypeTyConKey+varBangTypeTyConName    = thTc (fsLit "VarBangType")     varBangTypeTyConKey+ruleBndrTyConName      = thTc (fsLit "RuleBndr")      ruleBndrTyConKey+tySynEqnTyConName       = thTc  (fsLit "TySynEqn")       tySynEqnTyConKey roleTyConName           = libTc (fsLit "Role")           roleTyConKey-derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey-kindQTyConName          = libTc (fsLit "KindQ")          kindQTyConKey-tyVarBndrQTyConName     = libTc (fsLit "TyVarBndrQ")     tyVarBndrQTyConKey-derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey+derivClauseTyConName   = thTc (fsLit "DerivClause")   derivClauseTyConKey+kindTyConName          = thTc (fsLit "Kind")          kindTyConKey+tyVarBndrTyConName      = thTc (fsLit "TyVarBndr")     tyVarBndrTyConKey+derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey  -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name@@ -621,6 +621,9 @@ liftClassKey :: Unique liftClassKey = mkPreludeClassUnique 200 +quoteClassKey :: Unique+quoteClassKey = mkPreludeClassUnique 201+ {- ********************************************************************* *                                                                      *                      TyCon keys@@ -631,50 +634,47 @@ -- Check in PrelNames if you want to change this  expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,-    decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,-    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,-    tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,+    patTyConKey,+    stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,+    tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,-    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,-    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,-    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,-    overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique+    funDepTyConKey, predTyConKey,+    predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,+    overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey+      :: Unique expTyConKey             = mkPreludeTyConUnique 200 matchTyConKey           = mkPreludeTyConUnique 201 clauseTyConKey          = mkPreludeTyConUnique 202 qTyConKey               = mkPreludeTyConUnique 203 expQTyConKey            = mkPreludeTyConUnique 204-decQTyConKey            = mkPreludeTyConUnique 205 patTyConKey             = mkPreludeTyConUnique 206-matchQTyConKey          = mkPreludeTyConUnique 207-clauseQTyConKey         = mkPreludeTyConUnique 208-stmtQTyConKey           = mkPreludeTyConUnique 209-conQTyConKey            = mkPreludeTyConUnique 210+stmtTyConKey            = mkPreludeTyConUnique 209+conTyConKey             = mkPreludeTyConUnique 210 typeQTyConKey           = mkPreludeTyConUnique 211 typeTyConKey            = mkPreludeTyConUnique 212 decTyConKey             = mkPreludeTyConUnique 213-bangTypeQTyConKey       = mkPreludeTyConUnique 214-varBangTypeQTyConKey    = mkPreludeTyConUnique 215+bangTypeTyConKey       = mkPreludeTyConUnique 214+varBangTypeTyConKey     = mkPreludeTyConUnique 215 fieldExpTyConKey        = mkPreludeTyConUnique 216 fieldPatTyConKey        = mkPreludeTyConUnique 217 nameTyConKey            = mkPreludeTyConUnique 218 patQTyConKey            = mkPreludeTyConUnique 219-fieldPatQTyConKey       = mkPreludeTyConUnique 220-fieldExpQTyConKey       = mkPreludeTyConUnique 221 funDepTyConKey          = mkPreludeTyConUnique 222 predTyConKey            = mkPreludeTyConUnique 223 predQTyConKey           = mkPreludeTyConUnique 224-tyVarBndrQTyConKey      = mkPreludeTyConUnique 225+tyVarBndrTyConKey      = mkPreludeTyConUnique 225 decsQTyConKey           = mkPreludeTyConUnique 226-ruleBndrQTyConKey       = mkPreludeTyConUnique 227-tySynEqnQTyConKey       = mkPreludeTyConUnique 228+ruleBndrTyConKey       = mkPreludeTyConUnique 227+tySynEqnTyConKey        = mkPreludeTyConUnique 228 roleTyConKey            = mkPreludeTyConUnique 229 tExpTyConKey            = mkPreludeTyConUnique 230 injAnnTyConKey          = mkPreludeTyConUnique 231-kindQTyConKey           = mkPreludeTyConUnique 232+kindTyConKey           = mkPreludeTyConUnique 232 overlapTyConKey         = mkPreludeTyConUnique 233-derivClauseQTyConKey    = mkPreludeTyConUnique 234-derivStrategyQTyConKey  = mkPreludeTyConUnique 235+derivClauseTyConKey    = mkPreludeTyConUnique 234+derivStrategyTyConKey  = mkPreludeTyConUnique 235+decsTyConKey            = mkPreludeTyConUnique 236  {- ********************************************************************* *                                                                      *
compiler/profiling/ProfInit.hs view
@@ -10,7 +10,7 @@  import GhcPrelude -import CLabel+import GHC.Cmm.CLabel import CostCentre import DynFlags import Outputable
− compiler/rename/RnBinds.hs 
@@ -1,1334 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}--{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[RnBinds]{Renaming and dependency analysis of bindings}--This module does renaming and dependency analysis on value bindings in-the abstract syntax.  It does {\em not} do cycle-checks on class or-type-synonym declarations; those cannot be done at this stage because-they may be affected by renaming (which isn't fully worked out yet).--}--module RnBinds (-   -- Renaming top-level bindings-   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,--   -- Renaming local bindings-   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,--   -- Other bindings-   rnMethodBinds, renameSigs,-   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,-   makeMiniFixityEnv, MiniFixityEnv,-   HsSigCtxt(..)-   ) where--import GhcPrelude--import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )--import GHC.Hs-import TcRnMonad-import RnTypes-import RnPat-import RnNames-import RnEnv-import RnFixity-import RnUtils          ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn-                        , checkDupRdrNames, warnUnusedLocalBinds,-                        checkUnusedRecordWildcard-                        , checkDupAndShadowedNames, bindLocalNamesFV )-import DynFlags-import Module-import Name-import NameEnv-import NameSet-import RdrName          ( RdrName, rdrNameOcc )-import SrcLoc-import ListSetOps       ( findDupsEq )-import BasicTypes       ( RecFlag(..), TypeOrKind(..) )-import Digraph          ( SCC(..) )-import Bag-import Util-import Outputable-import UniqSet-import Maybes           ( orElse )-import OrdList-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.Foldable      ( toList )-import Data.List          ( partition, sort )-import Data.List.NonEmpty ( NonEmpty(..) )--{---- ToDo: Put the annotations into the monad, so that they arrive in the proper--- place and can be used when complaining.--The code tree received by the function @rnBinds@ contains definitions-in where-clauses which are all apparently mutually recursive, but which may-not really depend upon each other. For example, in the top level program-\begin{verbatim}-f x = y where a = x-              y = x-\end{verbatim}-the definitions of @a@ and @y@ do not depend on each other at all.-Unfortunately, the typechecker cannot always check such definitions.-\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive-definitions. In Proceedings of the International Symposium on Programming,-Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}-However, the typechecker usually can check definitions in which only the-strongly connected components have been collected into recursive bindings.-This is precisely what the function @rnBinds@ does.--ToDo: deal with case where a single monobinds binds the same variable-twice.--The vertag tag is a unique @Int@; the tags only need to be unique-within one @MonoBinds@, so that unique-Int plumbing is done explicitly-(heavy monad machinery not needed).---************************************************************************-*                                                                      *-* naming conventions                                                   *-*                                                                      *-************************************************************************--\subsection[name-conventions]{Name conventions}--The basic algorithm involves walking over the tree and returning a tuple-containing the new tree plus its free variables. Some functions, such-as those walking polymorphic bindings (HsBinds) and qualifier lists in-list comprehensions (@Quals@), return the variables bound in local-environments. These are then used to calculate the free variables of the-expression evaluated in these environments.--Conventions for variable names are as follows:-\begin{itemize}-\item-new code is given a prime to distinguish it from the old.--\item-a set of variables defined in @Exp@ is written @dvExp@--\item-a set of variables free in @Exp@ is written @fvExp@-\end{itemize}--************************************************************************-*                                                                      *-* analysing polymorphic bindings (HsBindGroup, HsBind)-*                                                                      *-************************************************************************--\subsubsection[dep-HsBinds]{Polymorphic bindings}--Non-recursive expressions are reconstructed without any changes at top-level, although their component expressions may have to be altered.-However, non-recursive expressions are currently not expected as-\Haskell{} programs, and this code should not be executed.--Monomorphic bindings contain information that is returned in a tuple-(a @FlatMonoBinds@) containing:--\begin{enumerate}-\item-a unique @Int@ that serves as the ``vertex tag'' for this binding.--\item-the name of a function or the names in a pattern. These are a set-referred to as @dvLhs@, the defined variables of the left hand side.--\item-the free variables of the body. These are referred to as @fvBody@.--\item-the definition's actual code. This is referred to as just @code@.-\end{enumerate}--The function @nonRecDvFv@ returns two sets of variables. The first is-the set of variables defined in the set of monomorphic bindings, while the-second is the set of free variables in those bindings.--The set of variables defined in a non-recursive binding is just the-union of all of them, as @union@ removes duplicates. However, the-free variables in each successive set of cumulative bindings is the-union of those in the previous set plus those of the newest binding after-the defined variables of the previous set have been removed.--@rnMethodBinds@ deals only with the declarations in class and-instance declarations.  It expects only to see @FunMonoBind@s, and-it expects the global environment to contain bindings for the binders-(which are all class operations).--************************************************************************-*                                                                      *-\subsubsection{ Top-level bindings}-*                                                                      *-************************************************************************--}---- for top-level bindings, we need to make top-level names,--- so we have a different entry point than for local bindings-rnTopBindsLHS :: MiniFixityEnv-              -> HsValBinds GhcPs-              -> RnM (HsValBindsLR GhcRn GhcPs)-rnTopBindsLHS fix_env binds-  = rnValBindsLHS (topRecNameMaker fix_env) binds--rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs-               -> RnM (HsValBinds GhcRn, DefUses)--- A hs-boot file has no bindings.--- Return a single HsBindGroup with empty binds and renamed signatures-rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)-  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)-        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs-        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }-rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)--{--*********************************************************-*                                                      *-                HsLocalBinds-*                                                      *-*********************************************************--}--rnLocalBindsAndThen :: HsLocalBinds GhcPs-                   -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))-                   -> RnM (result, FreeVars)--- This version (a) assumes that the binding vars are *not* already in scope---               (b) removes the binders from the free vars of the thing inside--- The parser doesn't produce ThenBinds-rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =-  thing_inside (EmptyLocalBinds x) emptyNameSet--rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside-  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->-      thing_inside (HsValBinds x val_binds')--rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do-    (binds',fv_binds) <- rnIPBinds binds-    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds-    return (thing, fvs_thing `plusFV` fv_binds)--rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec--rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)-rnIPBinds (IPBinds _ ip_binds ) = do-    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds-    return (IPBinds noExtField ip_binds', plusFVs fvs_s)-rnIPBinds (XHsIPBinds nec) = noExtCon nec--rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)-rnIPBind (IPBind _ ~(Left n) expr) = do-    (expr',fvExpr) <- rnLExpr expr-    return (IPBind noExtField (Left n) expr', fvExpr)-rnIPBind (XIPBind nec) = noExtCon nec--{--************************************************************************-*                                                                      *-                ValBinds-*                                                                      *-************************************************************************--}---- Renaming local binding groups--- Does duplicate/shadow check-rnLocalValBindsLHS :: MiniFixityEnv-                   -> HsValBinds GhcPs-                   -> RnM ([Name], HsValBindsLR GhcRn GhcPs)-rnLocalValBindsLHS fix_env binds-  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds--         -- Check for duplicates and shadowing-         -- Must do this *after* renaming the patterns-         -- See Note [Collect binders only after renaming] in GHC.Hs.Utils--         -- We need to check for dups here because we-         -- don't don't bind all of the variables from the ValBinds at once-         -- with bindLocatedLocals any more.-         ---         -- Note that we don't want to do this at the top level, since-         -- sorting out duplicates and shadowing there happens elsewhere.-         -- The behavior is even different. For example,-         --   import A(f)-         --   f = ...-         -- should not produce a shadowing warning (but it will produce-         -- an ambiguity warning if you use f), but-         --   import A(f)-         --   g = let f = ... in f-         -- should.-       ; let bound_names = collectHsValBinders binds'-             -- There should be only Ids, but if there are any bogus-             -- pattern synonyms, we'll collect them anyway, so that-             -- we don't generate subsequent out-of-scope messages-       ; envs <- getRdrEnvs-       ; checkDupAndShadowedNames envs bound_names--       ; return (bound_names, binds') }---- renames the left-hand sides--- generic version used both at the top level and for local binds--- does some error checking, but not what gets done elsewhere at the top level-rnValBindsLHS :: NameMaker-              -> HsValBinds GhcPs-              -> RnM (HsValBindsLR GhcRn GhcPs)-rnValBindsLHS topP (ValBinds x mbinds sigs)-  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds-       ; return $ ValBinds x mbinds' sigs }-  where-    bndrs = collectHsBindsBinders mbinds-    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs--rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)---- General version used both from the top-level and for local things--- Assumes the LHS vars are in scope------ Does not bind the local fixity declarations-rnValBindsRHS :: HsSigCtxt-              -> HsValBindsLR GhcRn GhcPs-              -> RnM (HsValBinds GhcRn, DefUses)--rnValBindsRHS ctxt (ValBinds _ mbinds sigs)-  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs-       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds-       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus--       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $-                          getPatSynBinds anal_binds-                -- The uses in binds_w_dus for PatSynBinds do not include-                -- variables used in the patsyn builders; see-                -- Note [Pattern synonym builders don't yield dependencies]-                -- But psb_fvs /does/ include those builder fvs.  So we-                -- add them back in here to avoid bogus warnings about-                -- unused variables (#12548)--             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs-                                     `plusDU` usesOnly patsyn_fvs-                            -- Put the sig uses *after* the bindings-                            -- so that the binders are removed from-                            -- the uses in the sigs--        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }--rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)---- Wrapper for local binds------ The *client* of this function is responsible for checking for unused binders;--- it doesn't (and can't: we don't have the thing inside the binds) happen here------ The client is also responsible for bringing the fixities into scope-rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes-                   -> HsValBindsLR GhcRn GhcPs-                   -> RnM (HsValBinds GhcRn, DefUses)-rnLocalValBindsRHS bound_names binds-  = rnValBindsRHS (LocalBindCtxt bound_names) binds---- for local binds--- wrapper that does both the left- and right-hand sides------ here there are no local fixity decls passed in;--- the local fixity decls come from the ValBinds sigs-rnLocalValBindsAndThen-  :: HsValBinds GhcPs-  -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))-  -> RnM (result, FreeVars)-rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside- = do   {     -- (A) Create the local fixity environment-          new_fixities <- makeMiniFixityEnv [ L loc sig-                                            | L loc (FixSig _ sig) <- sigs]--              -- (B) Rename the LHSes-        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds--              --     ...and bring them (and their fixities) into scope-        ; bindLocalNamesFV bound_names              $-          addLocalFixities new_fixities bound_names $ do--        {      -- (C) Do the RHS and thing inside-          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs-        ; (result, result_fvs) <- thing_inside binds' (allUses dus)--                -- Report unused bindings based on the (accurate)-                -- findUses.  E.g.-                --      let x = x in 3-                -- should report 'x' unused-        ; let real_uses = findUses dus result_fvs-              -- Insert fake uses for variables introduced implicitly by-              -- wildcards (#4404)-              rec_uses = hsValBindsImplicits binds'-              implicit_uses = mkNameSet $ concatMap snd-                                        $ rec_uses-        ; mapM_ (\(loc, ns) ->-                    checkUnusedRecordWildcard loc real_uses (Just ns))-                rec_uses-        ; warnUnusedLocalBinds bound_names-                                      (real_uses `unionNameSet` implicit_uses)--        ; let-            -- The variables "used" in the val binds are:-            --   (1) the uses of the binds (allUses)-            --   (2) the FVs of the thing-inside-            all_uses = allUses dus `plusFV` result_fvs-                -- Note [Unused binding hack]-                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~-                -- Note that *in contrast* to the above reporting of-                -- unused bindings, (1) above uses duUses to return *all*-                -- the uses, even if the binding is unused.  Otherwise consider:-                --      x = 3-                --      y = let p = x in 'x'    -- NB: p not used-                -- If we don't "see" the dependency of 'y' on 'x', we may put the-                -- bindings in the wrong order, and the type checker will complain-                -- that x isn't in scope-                ---                -- But note that this means we won't report 'x' as unused,-                -- whereas we would if we had { x = 3; p = x; y = 'x' }--        ; return (result, all_uses) }}-                -- The bound names are pruned out of all_uses-                -- by the bindLocalNamesFV call above--rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)---------------------------- renaming a single bind--rnBindLHS :: NameMaker-          -> SDoc-          -> HsBind GhcPs-          -- returns the renamed left-hand side,-          -- and the FreeVars *of the LHS*-          -- (i.e., any free variables of the pattern)-          -> RnM (HsBindLR GhcRn GhcPs)--rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })-  = do-      -- we don't actually use the FV processing of rnPatsAndThen here-      (pat',pat'_fvs) <- rnBindPat name_maker pat-      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })-                -- We temporarily store the pat's FVs in bind_fvs;-                -- gets updated to the FVs of the whole bind-                -- when doing the RHS below--rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })-  = do { name <- applyNameMaker name_maker rdr_name-       ; return (bind { fun_id = name-                      , fun_ext = noExtField }) }--rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })-  | isTopRecNameMaker name_maker-  = do { addLocM checkConName rdrname-       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already-       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }--  | otherwise  -- Pattern synonym, not at top level-  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake-                                        -- name so that we can carry on-       ; name <- applyNameMaker name_maker rdrname-       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }-  where-    localPatternSynonymErr :: SDoc-    localPatternSynonymErr-      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))-           2 (text "Pattern synonym declarations are only valid at top level")--rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)--rnLBind :: (Name -> [Name])      -- Signature tyvar function-        -> LHsBindLR GhcRn GhcPs-        -> RnM (LHsBind GhcRn, [Name], Uses)-rnLBind sig_fn (L loc bind)-  = setSrcSpan loc $-    do { (bind', bndrs, dus) <- rnBind sig_fn bind-       ; return (L loc bind', bndrs, dus) }---- assumes the left-hands-side vars are in scope-rnBind :: (Name -> [Name])        -- Signature tyvar function-       -> HsBindLR GhcRn GhcPs-       -> RnM (HsBind GhcRn, [Name], Uses)-rnBind _ bind@(PatBind { pat_lhs = pat-                       , pat_rhs = grhss-                                   -- pat fvs were stored in bind_fvs-                                   -- after processing the LHS-                       , pat_ext = pat_fvs })-  = do  { mod <- getModule-        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss--                -- No scoped type variables for pattern bindings-        ; let all_fvs = pat_fvs `plusFV` rhs_fvs-              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs-                -- Keep locally-defined Names-                -- As well as dependency analysis, we need these for the-                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan-              bndrs = collectPatBinders pat-              bind' = bind { pat_rhs  = grhss'-                           , pat_ext = fvs' }--              ok_nobind_pat-                  = -- See Note [Pattern bindings that bind no variables]-                    case unLoc pat of-                       WildPat {}   -> True-                       BangPat {}   -> True -- #9127, #13646-                       SplicePat {} -> True-                       _            -> False--        -- Warn if the pattern binds no variables-        -- See Note [Pattern bindings that bind no variables]-        ; whenWOptM Opt_WarnUnusedPatternBinds $-          when (null bndrs && not ok_nobind_pat) $-          addWarn (Reason Opt_WarnUnusedPatternBinds) $-          unusedPatBindWarn bind'--        ; fvs' `seq` -- See Note [Free-variable space leak]-          return (bind', bndrs, all_fvs) }--rnBind sig_fn bind@(FunBind { fun_id = name-                            , fun_matches = matches })-       -- invariant: no free vars here when it's a FunBind-  = do  { let plain_name = unLoc name--        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $-                                -- bindSigTyVars tests for LangExt.ScopedTyVars-                                 rnMatchGroup (mkPrefixFunRhs name)-                                              rnLExpr matches-        ; let is_infix = isInfixFunBind bind-        ; when is_infix $ checkPrecMatch plain_name matches'--        ; mod <- getModule-        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs-                -- Keep locally-defined Names-                -- As well as dependency analysis, we need these for the-                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan--        ; fvs' `seq` -- See Note [Free-variable space leak]-          return (bind { fun_matches = matches'-                       , fun_ext     = fvs' },-                  [plain_name], rhs_fvs)-      }--rnBind sig_fn (PatSynBind x bind)-  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind-        ; return (PatSynBind x bind', name, fvs) }--rnBind _ b = pprPanic "rnBind" (ppr b)--{- Note [Pattern bindings that bind no variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally, we want to warn about pattern bindings like-  Just _ = e-because they don't do anything!  But we have three exceptions:--* A wildcard pattern-       _ = rhs-  which (a) is not that different from  _v = rhs-        (b) is sometimes used to give a type sig for,-            or an occurrence of, a variable on the RHS--* A strict pattern binding; that is, one with an outermost bang-     !Just _ = e-  This can fail, so unlike the lazy variant, it is not a no-op.-  Moreover, #13646 argues that even for single constructor-  types, you might want to write the constructor.  See also #9127.--* A splice pattern-      $(th-lhs) = rhs-   It is impossible to determine whether or not th-lhs really-   binds any variable. We should disable the warning for any pattern-   which contain splices, but that is a more expensive check.--Note [Free-variable space leak]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have-    fvs' = trim fvs-and we seq fvs' before turning it as part of a record.--The reason is that trim is sometimes something like-    \xs -> intersectNameSet (mkNameSet bound_names) xs-and we don't want to retain the list bound_names. This showed up in-trac ticket #1136.--}--{- *********************************************************************-*                                                                      *-          Dependency analysis and other support functions-*                                                                      *-********************************************************************* -}--depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)-             -> ([(RecFlag, LHsBinds GhcRn)], DefUses)--- Dependency analysis; this is important so that--- unused-binding reporting is accurate-depAnalBinds binds_w_dus-  = (map get_binds sccs, toOL $ map get_du sccs)-  where-    sccs = depAnal (\(_, defs, _) -> defs)-                   (\(_, _, uses) -> nonDetEltsUniqSet uses)-                   -- It's OK to use nonDetEltsUniqSet here as explained in-                   -- Note [depAnal determinism] in NameEnv.-                   (bagToList binds_w_dus)--    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)-    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])--    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)-    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)-        where-          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]-          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]-------------------------- Bind the top-level forall'd type variables in the sigs.--- E.g  f :: forall a. a -> a---      f = rhs---      The 'a' scopes over the rhs------ NB: there'll usually be just one (for a function binding)---     but if there are many, one may shadow the rest; too bad!---      e.g  x :: forall a. [a] -> [a]---           y :: forall a. [(a,a)] -> a---           (x,y) = e---      In e, 'a' will be in scope, and it'll be the one from 'y'!--mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])--- Return a lookup function that maps an Id Name to the names--- of the type variables that should scope over its body.-mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []-  where-    env = mkHsSigEnv get_scoped_tvs sigs--    get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])-    -- Returns (binders, scoped tvs for those binders)-    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))-      = Just (names, hsScopedTvs sig_ty)-    get_scoped_tvs (L _ (TypeSig _ names sig_ty))-      = Just (names, hsWcScopedTvs sig_ty)-    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))-      = Just (names, hsScopedTvs sig_ty)-    get_scoped_tvs _ = Nothing---- Process the fixity declarations, making a FastString -> (Located Fixity) map--- (We keep the location around for reporting duplicate fixity declarations.)------ Checks for duplicates, but not that only locally defined things are fixed.--- Note: for local fixity declarations, duplicates would also be checked in---       check_sigs below.  But we also use this function at the top level.--makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv--makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls- where-   add_one_sig env (L loc (FixitySig _ names fixity)) =-     foldlM add_one env [ (loc,name_loc,name,fixity)-                        | L name_loc name <- names ]-   add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec--   add_one env (loc, name_loc, name,fixity) = do-     { -- this fixity decl is a duplicate iff-       -- the ReaderName's OccName's FastString is already in the env-       -- (we only need to check the local fix_env because-       --  definitions of non-local will be caught elsewhere)-       let { fs = occNameFS (rdrNameOcc name)-           ; fix_item = L loc fixity };--       case lookupFsEnv env fs of-         Nothing -> return $ extendFsEnv env fs fix_item-         Just (L loc' _) -> do-           { setSrcSpan loc $-             addErrAt name_loc (dupFixityDecl loc' name)-           ; return env}-     }--dupFixityDecl :: SrcSpan -> RdrName -> SDoc-dupFixityDecl loc rdr_name-  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),-          text "also at " <+> ppr loc]---{- *********************************************************************-*                                                                      *-                Pattern synonym bindings-*                                                                      *-********************************************************************* -}--rnPatSynBind :: (Name -> [Name])           -- Signature tyvar function-             -> PatSynBind GhcRn GhcPs-             -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)-rnPatSynBind sig_fn bind@(PSB { psb_id = L l name-                              , psb_args = details-                              , psb_def = pat-                              , psb_dir = dir })-       -- invariant: no free vars here when it's a FunBind-  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms-        ; unless pattern_synonym_ok (addErr patternSynonymErr)-        ; let scoped_tvs = sig_fn name--        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $-                                      rnPat PatSyn pat $ \pat' ->-         -- We check the 'RdrName's instead of the 'Name's-         -- so that the binding locations are reported-         -- from the left-hand side-            case details of-               PrefixCon vars ->-                   do { checkDupRdrNames vars-                      ; names <- mapM lookupPatSynBndr vars-                      ; return ( (pat', PrefixCon names)-                               , mkFVs (map unLoc names)) }-               InfixCon var1 var2 ->-                   do { checkDupRdrNames [var1, var2]-                      ; name1 <- lookupPatSynBndr var1-                      ; name2 <- lookupPatSynBndr var2-                      -- ; checkPrecMatch -- TODO-                      ; return ( (pat', InfixCon name1 name2)-                               , mkFVs (map unLoc [name1, name2])) }-               RecCon vars ->-                   do { checkDupRdrNames (map recordPatSynSelectorId vars)-                      ; let rnRecordPatSynField-                              (RecordPatSynField { recordPatSynSelectorId = visible-                                                 , recordPatSynPatVar = hidden })-                              = do { visible' <- lookupLocatedTopBndrRn visible-                                   ; hidden'  <- lookupPatSynBndr hidden-                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'-                                                                , recordPatSynPatVar = hidden' } }-                      ; names <- mapM rnRecordPatSynField  vars-                      ; return ( (pat', RecCon names)-                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }--        ; (dir', fvs2) <- case dir of-            Unidirectional -> return (Unidirectional, emptyFVs)-            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)-            ExplicitBidirectional mg ->-                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $-                                   rnMatchGroup (mkPrefixFunRhs (L l name))-                                                rnLExpr mg-                   ; return (ExplicitBidirectional mg', fvs) }--        ; mod <- getModule-        ; let fvs = fvs1 `plusFV` fvs2-              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs-                -- Keep locally-defined Names-                -- As well as dependency analysis, we need these for the-                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan--              bind' = bind{ psb_args = details'-                          , psb_def = pat'-                          , psb_dir = dir'-                          , psb_ext = fvs' }-              selector_names = case details' of-                                 RecCon names ->-                                  map (unLoc . recordPatSynSelectorId) names-                                 _ -> []--        ; fvs' `seq` -- See Note [Free-variable space leak]-          return (bind', name : selector_names , fvs1)-          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]-      }-  where-    -- See Note [Renaming pattern synonym variables]-    lookupPatSynBndr = wrapLocM lookupLocalOccRn--    patternSynonymErr :: SDoc-    patternSynonymErr-      = hang (text "Illegal pattern synonym declaration")-           2 (text "Use -XPatternSynonyms to enable this extension")--rnPatSynBind _ (XPatSynBind nec) = noExtCon nec--{--Note [Renaming pattern synonym variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We rename pattern synonym declaractions backwards to normal to reuse-the logic already implemented for renaming patterns.--We first rename the RHS of a declaration which brings into-scope the variables bound by the pattern (as they would be-in normal function definitions). We then lookup the variables-which we want to bind in this local environment.--It is crucial that we then only lookup in the *local* environment which-only contains the variables brought into scope by the pattern and nothing-else. Amazingly no-one encountered this bug for 3 GHC versions but-it was possible to define a pattern synonym which referenced global-identifiers and worked correctly.--```-x = 5--pattern P :: Int -> ()-pattern P x <- _--f (P x) = x--> f () = 5-```--See #13470 for the original report.--Note [Pattern synonym builders don't yield dependencies]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When renaming a pattern synonym that has an explicit builder,-references in the builder definition should not be used when-calculating dependencies. For example, consider the following pattern-synonym definition:--pattern P x <- C1 x where-  P x = f (C1 x)--f (P x) = C2 x--In this case, 'P' needs to be typechecked in two passes:--1. Typecheck the pattern definition of 'P', which fully determines the-   type of 'P'. This step doesn't require knowing anything about 'f',-   since the builder definition is not looked at.--2. Typecheck the builder definition, which needs the typechecked-   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind-   in TcBinds.tcValBinds.--This behaviour is implemented in 'tcValBinds', but it crucially-depends on 'P' not being put in a recursive group with 'f' (which-would make it look like a recursive pattern synonym a la 'pattern P =-P' which is unsound and rejected).--So:- * We do not include builder fvs in the Uses returned by rnPatSynBind-   (which is then used for dependency analysis)- * But we /do/ include them in the psb_fvs for the PatSynBind- * In rnValBinds we record these builder uses, to avoid bogus-   unused-variable warnings (#12548)--}--{- *********************************************************************-*                                                                      *-                Class/instance method bindings-*                                                                      *-********************************************************************* -}--{- @rnMethodBinds@ is used for the method bindings of a class and an instance-declaration.   Like @rnBinds@ but without dependency analysis.--NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.-That's crucial when dealing with an instance decl:-\begin{verbatim}-        instance Foo (T a) where-           op x = ...-\end{verbatim}-This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,-and unless @op@ occurs we won't treat the type signature of @op@ in the class-decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,-in many ways the @op@ in an instance decl is just like an occurrence, not-a binder.--}--rnMethodBinds :: Bool                   -- True <=> is a class declaration-              -> Name                   -- Class name-              -> [Name]                 -- Type variables from the class/instance header-              -> LHsBinds GhcPs         -- Binds-              -> [LSig GhcPs]           -- and signatures/pragmas-              -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)--- Used for---   * the default method bindings in a class decl---   * the method bindings in an instance decl-rnMethodBinds is_cls_decl cls ktv_names binds sigs-  = do { checkDupRdrNames (collectMethodBinders binds)-             -- Check that the same method is not given twice in the-             -- same instance decl      instance C T where-             --                       f x = ...-             --                       g y = ...-             --                       f x = ...-             -- We must use checkDupRdrNames because the Name of the-             -- method is the Name of the class selector, whose SrcSpan-             -- points to the class declaration; and we use rnMethodBinds-             -- for instance decls too--       -- Rename the bindings LHSs-       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds--       -- Rename the pragmas and signatures-       -- Annoyingly the type variables /are/ in scope for signatures, but-       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.-       --    instance Eq a => Eq (T a) where-       --       (==) :: a -> a -> a-       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}-       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs-             bound_nms = mkNameSet (collectHsBindsBinders binds')-             sig_ctxt | is_cls_decl = ClsDeclCtxt cls-                      | otherwise   = InstDeclCtxt bound_nms-       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags-       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $-                                        renameSigs sig_ctxt other_sigs--       -- Rename the bindings RHSs.  Again there's an issue about whether the-       -- type variables from the class/instance head are in scope.-       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables-       ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables-       ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $-              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'-                 ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)-                                           emptyFVs binds_w_dus-                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }--       ; return ( binds'', spec_inst_prags' ++ other_sigs'-                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }-  where-    -- For the method bindings in class and instance decls, we extend-    -- the type variable environment iff -XScopedTypeVariables-    maybe_extend_tyvar_env scoped_tvs thing_inside-       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside-       | otherwise  = thing_inside--rnMethodBindLHS :: Bool -> Name-                -> LHsBindLR GhcPs GhcPs-                -> LHsBindsLR GhcRn GhcPs-                -> RnM (LHsBindsLR GhcRn GhcPs)-rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest-  = setSrcSpan loc $ do-    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name-                     -- We use the selector name as the binder-       ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }-       ; return (L loc bind' `consBag` rest ) }---- Report error for all other forms of bindings--- This is why we use a fold rather than map-rnMethodBindLHS is_cls_decl _ (L loc bind) rest-  = do { addErrAt loc $-         vcat [ what <+> text "not allowed in" <+> decl_sort-              , nest 2 (ppr bind) ]-       ; return rest }-  where-    decl_sort | is_cls_decl = text "class declaration:"-              | otherwise   = text "instance declaration:"-    what = case bind of-              PatBind {}    -> text "Pattern bindings (except simple variables)"-              PatSynBind {} -> text "Pattern synonyms"-                               -- Associated pattern synonyms are not implemented yet-              _ -> pprPanic "rnMethodBind" (ppr bind)--{--************************************************************************-*                                                                      *-\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}-*                                                                      *-************************************************************************--@renameSigs@ checks for:-\begin{enumerate}-\item more than one sig for one thing;-\item signatures given for things not bound here;-\end{enumerate}--At the moment we don't gather free-var info from the types in-signatures.  We'd only need this if we wanted to report unused tyvars.--}--renameSigs :: HsSigCtxt-           -> [LSig GhcPs]-           -> RnM ([LSig GhcRn], FreeVars)--- Renames the signatures and performs error checks-renameSigs ctxt sigs-  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)--        ; checkDupMinimalSigs sigs--        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs--        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'-        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced--        ; return (good_sigs, sig_fvs) }--------------------------- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory--- because this won't work for:---      instance Foo T where---        {-# INLINE op #-}---        Baz.op = ...--- We'll just rename the INLINE prag to refer to whatever other 'op'--- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)--- Doesn't seem worth much trouble to sort this.--renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)-renameSig _ (IdSig _ x)-  = return (IdSig noExtField x, emptyFVs)    -- Actually this never occurs--renameSig ctxt sig@(TypeSig _ vs ty)-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs-        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)-        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty-        ; return (TypeSig noExtField new_vs new_ty, fvs) }--renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)-  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures-        ; when (is_deflt && not defaultSigs_on) $-          addErr (defaultSigErr sig)-        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs-        ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty-        ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }-  where-    (v1:_) = vs-    ty_ctxt = GenericCtx (text "a class method signature for"-                          <+> quotes (ppr v1))--renameSig _ (SpecInstSig _ src ty)-  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty-        ; return (SpecInstSig noExtField src new_ty,fvs) }---- {-# SPECIALISE #-} pragmas can refer to imported Ids--- so, in the top-level case (when mb_names is Nothing)--- we use lookupOccRn.  If there's both an imported and a local 'f'--- then the SPECIALISE pragma is ambiguous, unlike all other signatures-renameSig ctxt sig@(SpecSig _ v tys inl)-  = do  { new_v <- case ctxt of-                     TopSigCtxt {} -> lookupLocatedOccRn v-                     _             -> lookupSigOccRn ctxt sig v-        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys-        ; return (SpecSig noExtField new_v new_ty inl, fvs) }-  where-    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"-                          <+> quotes (ppr v))-    do_one (tys,fvs) ty-      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty-           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }--renameSig ctxt sig@(InlineSig _ v s)-  = do  { new_v <- lookupSigOccRn ctxt sig v-        ; return (InlineSig noExtField new_v s, emptyFVs) }--renameSig ctxt (FixSig _ fsig)-  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig-        ; return (FixSig noExtField new_fsig, emptyFVs) }--renameSig ctxt sig@(MinimalSig _ s (L l bf))-  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf-       return (MinimalSig noExtField s (L l new_bf), emptyFVs)--renameSig ctxt sig@(PatSynSig _ vs ty)-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs-        ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty-        ; return (PatSynSig noExtField new_vs ty', fvs) }-  where-    ty_ctxt = GenericCtx (text "a pattern synonym signature for"-                          <+> ppr_sig_bndrs vs)--renameSig ctxt sig@(SCCFunSig _ st v s)-  = do  { new_v <- lookupSigOccRn ctxt sig v-        ; return (SCCFunSig noExtField st new_v s, emptyFVs) }---- COMPLETE Sigs can refer to imported IDs which is why we use--- lookupLocatedOccRn rather than lookupSigOccRn-renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)-  = do new_bf <- traverse lookupLocatedOccRn bf-       new_mty  <- traverse lookupLocatedOccRn mty--       this_mod <- fmap tcg_mod getGblEnv-       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do-         -- Why 'any'? See Note [Orphan COMPLETE pragmas]-         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError--       return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs)-  where-    orphanError :: SDoc-    orphanError =-      text "Orphan COMPLETE pragmas not supported" $$-      text "A COMPLETE pragma must mention at least one data constructor" $$-      text "or pattern synonym defined in the same module."--renameSig _ (XSig nec) = noExtCon nec--{--Note [Orphan COMPLETE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We define a COMPLETE pragma to be a non-orphan if it includes at least-one conlike defined in the current module. Why is this sufficient?-Well if you have a pattern match--  case expr of-    P1 -> ...-    P2 -> ...-    P3 -> ...--any COMPLETE pragma which mentions a conlike other than P1, P2 or P3-will not be of any use in verifying that the pattern match is-exhaustive. So as we have certainly read the interface files that-define P1, P2 and P3, we will have loaded all non-orphan COMPLETE-pragmas that could be relevant to this pattern match.--For now we simply disallow orphan COMPLETE pragmas, as the added-complexity of supporting them properly doesn't seem worthwhile.--}--ppr_sig_bndrs :: [Located RdrName] -> SDoc-ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)--okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool-okHsSig ctxt (L _ sig)-  = case (sig, ctxt) of-     (ClassOpSig {}, ClsDeclCtxt {})  -> True-     (ClassOpSig {}, InstDeclCtxt {}) -> True-     (ClassOpSig {}, _)               -> False--     (TypeSig {}, ClsDeclCtxt {})  -> False-     (TypeSig {}, InstDeclCtxt {}) -> False-     (TypeSig {}, _)               -> True--     (PatSynSig {}, TopSigCtxt{}) -> True-     (PatSynSig {}, _)            -> False--     (FixSig {}, InstDeclCtxt {}) -> False-     (FixSig {}, _)               -> True--     (IdSig {}, TopSigCtxt {})   -> True-     (IdSig {}, InstDeclCtxt {}) -> True-     (IdSig {}, _)               -> False--     (InlineSig {}, HsBootCtxt {}) -> False-     (InlineSig {}, _)             -> True--     (SpecSig {}, TopSigCtxt {})    -> True-     (SpecSig {}, LocalBindCtxt {}) -> True-     (SpecSig {}, InstDeclCtxt {})  -> True-     (SpecSig {}, _)                -> False--     (SpecInstSig {}, InstDeclCtxt {}) -> True-     (SpecInstSig {}, _)               -> False--     (MinimalSig {}, ClsDeclCtxt {}) -> True-     (MinimalSig {}, _)              -> False--     (SCCFunSig {}, HsBootCtxt {}) -> False-     (SCCFunSig {}, _)             -> True--     (CompleteMatchSig {}, TopSigCtxt {} ) -> True-     (CompleteMatchSig {}, _)              -> False--     (XSig nec, _) -> noExtCon nec----------------------findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]--- Check for duplicates on RdrName version,--- because renamed version has unboundName for--- not-in-scope binders, which gives bogus dup-sig errors--- NB: in a class decl, a 'generic' sig is not considered---     equal to an ordinary sig, so we allow, say---           class C a where---             op :: a -> a---             default op :: Eq a => a -> a-findDupSigs sigs-  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)-  where-    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)-    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]-    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]-    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]-    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]-    expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]-    expand_sig _ = []--    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2-    mtch (FixSig {})           (FixSig {})         = True-    mtch (InlineSig {})        (InlineSig {})      = True-    mtch (TypeSig {})          (TypeSig {})        = True-    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2-    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True-    mtch (SCCFunSig{})         (SCCFunSig{})       = True-    mtch _ _ = False---- Warn about multiple MINIMAL signatures-checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()-checkDupMinimalSigs sigs-  = case filter isMinimalLSig sigs of-      minSigs@(_:_:_) -> dupMinimalSigErr minSigs-      _ -> return ()--{--************************************************************************-*                                                                      *-\subsection{Match}-*                                                                      *-************************************************************************--}--rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name-             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-             -> MatchGroup GhcPs (Located (body GhcPs))-             -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)-rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })-  = do { empty_case_ok <- xoptM LangExt.EmptyCase-       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))-       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms-       ; return (mkMatchGroup origin new_ms, ms_fvs) }-rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec--rnMatch :: Outputable (body GhcPs) => HsMatchContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> LMatch GhcPs (Located (body GhcPs))-        -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)-rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)--rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name-         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-         -> Match GhcPs (Located (body GhcPs))-         -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)-rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })-  = do  { -- Note that there are no local fixity decls for matches-        ; rnPats ctxt pats      $ \ pats' -> do-        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss-        ; let mf' = case (ctxt, mf) of-                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })-                                            -> mf { mc_fun = L lf funid }-                      _                     -> ctxt-        ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats'-                        , m_grhss = grhss'}, grhss_fvs ) }}-rnMatch' _ _ (XMatch nec) = noExtCon nec--emptyCaseErr :: HsMatchContext Name -> SDoc-emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)-                       2 (text "Use EmptyCase to allow this")-  where-    pp_ctxt = case ctxt of-                CaseAlt    -> text "case expression"-                LambdaExpr -> text "\\case expression"-                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt--{--************************************************************************-*                                                                      *-\subsubsection{Guarded right-hand sides (GRHSs)}-*                                                                      *-************************************************************************--}--rnGRHSs :: HsMatchContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> GRHSs GhcPs (Located (body GhcPs))-        -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)-rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))-  = rnLocalBindsAndThen binds   $ \ binds' _ -> do-    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss-    return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)-rnGRHSs _ _ (XGRHSs nec) = noExtCon nec--rnGRHS :: HsMatchContext Name-       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-       -> LGRHS GhcPs (Located (body GhcPs))-       -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)-rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)--rnGRHS' :: HsMatchContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> GRHS GhcPs (Located (body GhcPs))-        -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)-rnGRHS' ctxt rnBody (GRHS _ guards rhs)-  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards-        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->-                                    rnBody rhs--        ; unless (pattern_guards_allowed || is_standard_guard guards')-                 (addWarn NoReason (nonStdGuardErr guards'))--        ; return (GRHS noExtField guards' rhs', fvs) }-  where-        -- Standard Haskell 1.4 guards are just a single boolean-        -- expression, rather than a list of qualifiers as in the-        -- Glasgow extension-    is_standard_guard []                  = True-    is_standard_guard [L _ (BodyStmt {})] = True-    is_standard_guard _                   = False-rnGRHS' _ _ (XGRHS nec) = noExtCon nec--{--*********************************************************-*                                                       *-        Source-code fixity declarations-*                                                       *-*********************************************************--}--rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)--- Rename a fixity decl, so we can put--- the renamed decl in the renamed syntax tree--- Errors if the thing being fixed is not defined locally.-rnSrcFixityDecl sig_ctxt = rn_decl-  where-    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)-        -- GHC extension: look up both the tycon and data con-        -- for con-like things; hence returning a list-        -- If neither are in scope, report an error; otherwise-        -- return a fixity sig for each (slightly odd)-    rn_decl (FixitySig _ fnames fixity)-      = do names <- concatMapM lookup_one fnames-           return (FixitySig noExtField names fixity)-    rn_decl (XFixitySig nec) = noExtCon nec--    lookup_one :: Located RdrName -> RnM [Located Name]-    lookup_one (L name_loc rdr_name)-      = setSrcSpan name_loc $-                    -- This lookup will fail if the name is not defined in the-                    -- same binding group as this fixity declaration.-        do names <- lookupLocalTcNames sig_ctxt what rdr_name-           return [ L name_loc name | (_, name) <- names ]-    what = text "fixity signature"--{--************************************************************************-*                                                                      *-\subsection{Error messages}-*                                                                      *-************************************************************************--}--dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()-dupSigDeclErr pairs@((L loc name, sig) :| _)-  = addErrAt loc $-    vcat [ text "Duplicate" <+> what_it_is-           <> text "s for" <+> quotes (ppr name)-         , text "at" <+> vcat (map ppr $ sort-                                       $ map (getLoc . fst)-                                       $ toList pairs)-         ]-  where-    what_it_is = hsSigDoc sig--misplacedSigErr :: LSig GhcRn -> RnM ()-misplacedSigErr (L loc sig)-  = addErrAt loc $-    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]--defaultSigErr :: Sig GhcPs -> SDoc-defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")-                              2 (ppr sig)-                         , text "Use DefaultSignatures to enable default signatures" ]--bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc-bindsInHsBootFile mbinds-  = hang (text "Bindings in hs-boot files are not allowed")-       2 (ppr mbinds)--nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc-nonStdGuardErr guards-  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")-       4 (interpp'SP guards)--unusedPatBindWarn :: HsBind GhcRn -> SDoc-unusedPatBindWarn bind-  = hang (text "This pattern-binding binds no variables:")-       2 (ppr bind)--dupMinimalSigErr :: [LSig GhcPs] -> RnM ()-dupMinimalSigErr sigs@(L loc _ : _)-  = addErrAt loc $-    vcat [ text "Multiple minimal complete definitions"-         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)-         , text "Combine alternative minimal complete definitions with `|'" ]-dupMinimalSigErr [] = panic "dupMinimalSigErr"
− compiler/rename/RnEnv.hs 
@@ -1,1702 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-2006--RnEnv contains functions which convert RdrNames into Names.---}--{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}--module RnEnv (-        newTopSrcBinder,-        lookupLocatedTopBndrRn, lookupTopBndrRn,-        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,-        lookupLocalOccRn_maybe, lookupInfoOccRn,-        lookupLocalOccThLvl_maybe, lookupLocalOccRn,-        lookupTypeOccRn,-        lookupGlobalOccRn, lookupGlobalOccRn_maybe,-        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,--        ChildLookupResult(..),-        lookupSubBndrOcc_helper,-        combineChildLookupResult, -- Called by lookupChildrenExport--        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,-        lookupSigCtxtOccRn,--        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,-        lookupConstructorFields,--        lookupGreAvailRn,--        -- Rebindable Syntax-        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,-        lookupIfThenElse,--        -- Constructing usage information-        addUsedGRE, addUsedGREs, addUsedDataCons,----        dataTcOccs, --TODO: Move this somewhere, into utils?--    ) where--#include "HsVersions.h"--import GhcPrelude--import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe )-import IfaceEnv-import GHC.Hs-import RdrName-import HscTypes-import TcEnv-import TcRnMonad-import RdrHsSyn         ( filterCTuple, setRdrNameSpace )-import TysWiredIn-import Name-import NameSet-import NameEnv-import Avail-import Module-import ConLike-import DataCon-import TyCon-import ErrUtils         ( MsgDoc )-import PrelNames        ( rOOT_MAIN )-import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))-import SrcLoc-import Outputable-import UniqSet          ( uniqSetAny )-import Util-import Maybes-import DynFlags-import FastString-import Control.Monad-import ListSetOps       ( minusList )-import qualified GHC.LanguageExtensions as LangExt-import RnUnbound-import RnUtils-import qualified Data.Semigroup as Semi-import Data.Either      ( partitionEithers )-import Data.List        (find)--{--*********************************************************-*                                                      *-                Source-code binders-*                                                      *-*********************************************************--Note [Signature lazy interface loading]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--GHC's lazy interface loading can be a bit confusing, so this Note is an-empirical description of what happens in one interesting case. When-compiling a signature module against an its implementation, we do NOT-load interface files associated with its names until after the type-checking phase.  For example:--    module ASig where-        data T-        f :: T -> T--Suppose we compile this with -sig-of "A is ASig":--    module B where-        data T = T-        f T = T--    module A(module B) where-        import B--During type checking, we'll load A.hi because we need to know what the-RdrEnv for the module is, but we DO NOT load the interface for B.hi!-It's wholly unnecessary: our local definition 'data T' in ASig is all-the information we need to finish type checking.  This is contrast to-type checking of ordinary Haskell files, in which we would not have the-local definition "data T" and would need to consult B.hi immediately.-(Also, this situation never occurs for hs-boot files, since you're not-allowed to reexport from another module.)--After type checking, we then check that the types we provided are-consistent with the backing implementation (in checkHiBootOrHsigIface).-At this point, B.hi is loaded, because we need something to compare-against.--I discovered this behavior when trying to figure out why type class-instances for Data.Map weren't in the EPS when I was type checking a-test very much like ASig (sigof02dm): the associated interface hadn't-been loaded yet!  (The larger issue is a moot point, since an instance-declared in a signature can never be a duplicate.)--This behavior might change in the future.  Consider this-alternate module B:--    module B where-        {-# DEPRECATED T, f "Don't use" #-}-        data T = T-        f T = T--One might conceivably want to report deprecation warnings when compiling-ASig with -sig-of B, in which case we need to look at B.hi to find the-deprecation warnings during renaming.  At the moment, you don't get any-warning until you use the identifier further downstream.  This would-require adjusting addUsedGRE so that during signature compilation,-we do not report deprecation warnings for LocalDef.  See also-Note [Handling of deprecations]--}--newTopSrcBinder :: Located RdrName -> RnM Name-newTopSrcBinder (L loc rdr_name)-  | Just name <- isExact_maybe rdr_name-  =     -- This is here to catch-        --   (a) Exact-name binders created by Template Haskell-        --   (b) The PrelBase defn of (say) [] and similar, for which-        --       the parser reads the special syntax and returns an Exact RdrName-        -- We are at a binding site for the name, so check first that it-        -- the current module is the correct one; otherwise GHC can get-        -- very confused indeed. This test rejects code like-        --      data T = (,) Int Int-        -- unless we are in GHC.Tup-    if isExternalName name then-      do { this_mod <- getModule-         ; unless (this_mod == nameModule name)-                  (addErrAt loc (badOrigBinding rdr_name))-         ; return name }-    else   -- See Note [Binders in Template Haskell] in Convert.hs-      do { this_mod <- getModule-         ; externaliseName this_mod name }--  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name-  = do  { this_mod <- getModule-        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)-                 (addErrAt loc (badOrigBinding rdr_name))-        -- When reading External Core we get Orig names as binders,-        -- but they should agree with the module gotten from the monad-        ---        -- We can get built-in syntax showing up here too, sadly.  If you type-        --      data T = (,,,)-        -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon-        -- uses setRdrNameSpace to make it into a data constructors.  At that point-        -- the nice Exact name for the TyCon gets swizzled to an Orig name.-        -- Hence the badOrigBinding error message.-        ---        -- Except for the ":Main.main = ..." definition inserted into-        -- the Main module; ugh!--        -- Because of this latter case, we call newGlobalBinder with a module from-        -- the RdrName, not from the environment.  In principle, it'd be fine to-        -- have an arbitrary mixture of external core definitions in a single module,-        -- (apart from module-initialisation issues, perhaps).-        ; newGlobalBinder rdr_mod rdr_occ loc }--  | otherwise-  = do  { when (isQual rdr_name)-                 (addErrAt loc (badQualBndrErr rdr_name))-                -- Binders should not be qualified; if they are, and with a different-                -- module name, we get a confusing "M.T is not in scope" error later--        ; stage <- getStage-        ; if isBrackStage stage then-                -- We are inside a TH bracket, so make an *Internal* name-                -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames-             do { uniq <- newUnique-                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }-          else-             do { this_mod <- getModule-                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)-                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }-        }--{--*********************************************************-*                                                      *-        Source code occurrences-*                                                      *-*********************************************************--Looking up a name in the RnEnv.--Note [Type and class operator definitions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to reject all of these unless we have -XTypeOperators (#3265)-   data a :*: b  = ...-   class a :*: b where ...-   data (:*:) a b  = ....-   class (:*:) a b where ...-The latter two mean that we are not just looking for a-*syntactically-infix* declaration, but one that uses an operator-OccName.  We use OccName.isSymOcc to detect that case, which isn't-terribly efficient, but there seems to be no better way.--}---- Can be made to not be exposed--- Only used unwrapped in rnAnnProvenance-lookupTopBndrRn :: RdrName -> RnM Name-lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n-                       case nopt of-                         Just n' -> return n'-                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)-                                       unboundName WL_LocalTop n--lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)-lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn--lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)--- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',--- and there may be several imported 'f's too, which must not confuse us.--- For example, this is OK:---      import Foo( f )---      infix 9 f       -- The 'f' here does not need to be qualified---      f x = x         -- Nor here, of course--- So we have to filter out the non-local ones.------ A separate function (importsFromLocalDecls) reports duplicate top level--- decls, so here it's safe just to choose an arbitrary one.------ There should never be a qualified name in a binding position in Haskell,--- but there can be if we have read in an external-Core file.--- The Haskell parser checks for the illegal qualified name in Haskell--- source files, so we don't need to do so here.--lookupTopBndrRn_maybe rdr_name =-  lookupExactOrOrig rdr_name Just $-    do  {  -- Check for operators in type or class declarations-           -- See Note [Type and class operator definitions]-          let occ = rdrNameOcc rdr_name-        ; when (isTcOcc occ && isSymOcc occ)-               (do { op_ok <- xoptM LangExt.TypeOperators-                   ; unless op_ok (addErr (opDeclErr rdr_name)) })--        ; env <- getGlobalRdrEnv-        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of-            [gre] -> return (Just (gre_name gre))-            _     -> return Nothing  -- Ambiguous (can't happen) or unbound-    }---------------------------------------------------- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].--- This adds an error if the name cannot be found.-lookupExactOcc :: Name -> RnM Name-lookupExactOcc name-  = do { result <- lookupExactOcc_either name-       ; case result of-           Left err -> do { addErr err-                          ; return name }-           Right name' -> return name' }---- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].--- This never adds an error, but it may return one.-lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)--- See Note [Looking up Exact RdrNames]-lookupExactOcc_either name-  | Just thing <- wiredInNameTyThing_maybe name-  , Just tycon <- case thing of-                    ATyCon tc                 -> Just tc-                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)-                    _                         -> Nothing-  , isTupleTyCon tycon-  = do { checkTupSize (tyConArity tycon)-       ; return (Right name) }--  | isExternalName name-  = return (Right name)--  | otherwise-  = do { env <- getGlobalRdrEnv-       ; let -- See Note [Splicing Exact names]-             main_occ =  nameOccName name-             demoted_occs = case demoteOccName main_occ of-                              Just occ -> [occ]-                              Nothing  -> []-             gres = [ gre | occ <- main_occ : demoted_occs-                          , gre <- lookupGlobalRdrEnv env occ-                          , gre_name gre == name ]-       ; case gres of-           [gre] -> return (Right (gre_name gre))--           []    -> -- See Note [Splicing Exact names]-                    do { lcl_env <- getLocalRdrEnv-                       ; if name `inLocalRdrEnvScope` lcl_env-                         then return (Right name)-                         else-                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv-                            ; th_topnames <- readTcRef th_topnames_var-                            ; if name `elemNameSet` th_topnames-                              then return (Right name)-                              else return (Left exact_nm_err)-                            }-                       }-           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]-       }-  where-    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))-                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "-                              , text "perhaps via newName, but did not bind it"-                              , text "If that's it, then -ddump-splices might be useful" ])--sameNameErr :: [GlobalRdrElt] -> MsgDoc-sameNameErr [] = panic "addSameNameErr: empty list"-sameNameErr gres@(_ : _)-  = hang (text "Same exact name in multiple name-spaces:")-       2 (vcat (map pp_one sorted_names) $$ th_hint)-  where-    sorted_names = sortWith nameSrcLoc (map gre_name gres)-    pp_one name-      = hang (pprNameSpace (occNameSpace (getOccName name))-              <+> quotes (ppr name) <> comma)-           2 (text "declared at:" <+> ppr (nameSrcLoc name))--    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"-                   , text "perhaps via newName, in different name-spaces."-                   , text "If that's it, then -ddump-splices might be useful" ]---------------------------------------------------lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name--- This is called on the method name on the left-hand side of an--- instance declaration binding. eg.  instance Functor T where---                                       fmap = ...---                                       ^^^^ called on this--- Regardless of how many unqualified fmaps are in scope, we want--- the one that comes from the Functor class.------ Furthermore, note that we take no account of whether the--- name is only in scope qualified.  I.e. even if method op is--- in scope as M.op, we still allow plain 'op' on the LHS of--- an instance decl------ The "what" parameter says "method" or "associated type",--- depending on what we are looking up-lookupInstDeclBndr cls what rdr-  = do { when (isQual rdr)-              (addErr (badQualBndrErr rdr))-                -- In an instance decl you aren't allowed-                -- to use a qualified name for the method-                -- (Although it'd make perfect sense.)-       ; mb_name <- lookupSubBndrOcc-                          False -- False => we don't give deprecated-                                -- warnings when a deprecated class-                                -- method is defined. We only warn-                                -- when it's used-                          cls doc rdr-       ; case mb_name of-           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }-           Right nm -> return nm }-  where-    doc = what <+> text "of class" <+> quotes (ppr cls)--------------------------------------------------lookupFamInstName :: Maybe Name -> Located RdrName-                  -> RnM (Located Name)--- Used for TyData and TySynonym family instances only,--- See Note [Family instance binders]-lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f RnBinds.rnMethodBind-  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr-lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*-  = lookupLocatedOccRn tc_rdr--------------------------------------------------lookupConstructorFields :: Name -> RnM [FieldLabel]--- Look up the fields of a given constructor---   *  For constructors from this module, use the record field env,---      which is itself gathered from the (as yet un-typechecked)---      data type decls------    * For constructors from imported modules, use the *type* environment---      since imported modles are already compiled, the info is conveniently---      right there--lookupConstructorFields con_name-  = do  { this_mod <- getModule-        ; if nameIsLocalOrFrom this_mod con_name then-          do { field_env <- getRecFieldEnv-             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)-             ; return (lookupNameEnv field_env con_name `orElse` []) }-          else-          do { con <- tcLookupConLike con_name-             ; traceTc "lookupCF 2" (ppr con)-             ; return (conLikeFieldLabels con) } }----- In CPS style as `RnM r` is monadic-lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r-lookupExactOrOrig rdr_name res k-  | Just n <- isExact_maybe rdr_name   -- This happens in derived code-  = res <$> lookupExactOcc n-  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name-  = res <$> lookupOrig rdr_mod rdr_occ-  | otherwise = k------------------------------------------------------ | Look up an occurrence of a field in record construction or pattern--- matching (but not update).  When the -XDisambiguateRecordFields--- flag is on, take account of the data constructor name to--- disambiguate which field to use.------ See Note [DisambiguateRecordFields].-lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual-                                -- Just con => use data con to disambiguate-                  -> RdrName-                  -> RnM Name-lookupRecFieldOcc mb_con rdr_name-  | Just con <- mb_con-  , isUnboundName con  -- Avoid error cascade-  = return (mkUnboundNameRdr rdr_name)-  | Just con <- mb_con-  = do { flds <- lookupConstructorFields con-       ; env <- getGlobalRdrEnv-       ; let lbl      = occNameFS (rdrNameOcc rdr_name)-             mb_field = do fl <- find ((== lbl) . flLabel) flds-                           -- We have the label, now check it is in-                           -- scope (with the correct qualifier if-                           -- there is one, hence calling pickGREs).-                           gre <- lookupGRE_FieldLabel env fl-                           guard (not (isQual rdr_name-                                         && null (pickGREs rdr_name [gre])))-                           return (fl, gre)-       ; case mb_field of-           Just (fl, gre) -> do { addUsedGRE True gre-                                ; return (flSelector fl) }-           Nothing        -> lookupGlobalOccRn rdr_name }-             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-  | otherwise-  -- This use of Global is right as we are looking up a selector which-  -- can only be defined at the top level.-  = lookupGlobalOccRn rdr_name--{- Note [DisambiguateRecordFields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are looking up record fields in record construction or pattern-matching, we can take advantage of the data constructor name to-resolve fields that would otherwise be ambiguous (provided the--XDisambiguateRecordFields flag is on).--For example, consider:--   data S = MkS { x :: Int }-   data T = MkT { x :: Int }--   e = MkS { x = 3 }--When we are renaming the occurrence of `x` in `e`, instead of looking-`x` up directly (and finding both fields), lookupRecFieldOcc will-search the fields of `MkS` to find the only possible `x` the user can-mean.--Of course, we still have to check the field is in scope, using-lookupGRE_FieldLabel.  The handling of qualified imports is slightly-subtle: the occurrence may be unqualified even if the field is-imported only qualified (but if the occurrence is qualified, the-qualifier must be correct). For example:--   module A where-     data S = MkS { x :: Int }-     data T = MkT { x :: Int }--   module B where-     import qualified A (S(..))-     import A (T(MkT))--     e1 = MkT   { x = 3 }   -- x not in scope, so fail-     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail-     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)--In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,-lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard-will fail because the field RdrName `B.x` is qualified and pickGREs-rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the-GRE for `A.x` and the guard will succeed because the field RdrName `x`-is unqualified.---Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we fail to find the field or it is not in scope, mb_field-will be False, and we fall back on looking it up normally using-lookupGlobalOccRn.  We don't report an error immediately because the-actual problem might be located elsewhere.  For example (#9975):--   data Test = Test { x :: Int }-   pattern Test wat = Test { x = wat }--Here there are multiple declarations of Test (as a data constructor-and as a pattern synonym), which will be reported as an error.  We-shouldn't also report an error about the occurrence of `x` in the-pattern synonym RHS.  However, if the pattern synonym gets added to-the environment first, we will try and fail to find `x` amongst the-(nonexistent) fields of the pattern synonym.--Alternatively, the scope check can fail due to Template Haskell.-Consider (#12130):--   module Foo where-     import M-     b = $(funny)--   module M(funny) where-     data T = MkT { x :: Int }-     funny :: Q Exp-     funny = [| MkT { x = 3 } |]--When we splice, `MkT` is not lexically in scope, so-lookupGRE_FieldLabel will fail.  But there is no need for-disambiguation anyway, because `x` is an original name, and-lookupGlobalOccRn will find it.--}------ | Used in export lists to lookup the children.-lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName-                        -> RnM ChildLookupResult-lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name-  | isUnboundName parent-    -- Avoid an error cascade-  = return (FoundName NoParent (mkUnboundNameRdr rdr_name))--  | otherwise = do-  gre_env <- getGlobalRdrEnv--  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)-  -- Disambiguate the lookup based on the parent information.-  -- The remaining GREs are things that we *could* export here, note that-  -- this includes things which have `NoParent`. Those are sorted in-  -- `checkPatSynParent`.-  traceRn "parent" (ppr parent)-  traceRn "lookupExportChild original_gres:" (ppr original_gres)-  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)-  case picked_gres original_gres of-    NoOccurrence ->-      noMatchingParentErr original_gres-    UniqueOccurrence g ->-      if must_have_parent then noMatchingParentErr original_gres-                          else checkFld g-    DisambiguatedOccurrence g ->-      checkFld g-    AmbiguousOccurrence gres ->-      mkNameClashErr gres-    where-        -- Convert into FieldLabel if necessary-        checkFld :: GlobalRdrElt -> RnM ChildLookupResult-        checkFld g@GRE{gre_name, gre_par} = do-          addUsedGRE warn_if_deprec g-          return $ case gre_par of-            FldParent _ mfs ->-              FoundFL  (fldParentToFieldLabel gre_name mfs)-            _ -> FoundName gre_par gre_name--        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel-        fldParentToFieldLabel name mfs =-          case mfs of-            Nothing ->-              let fs = occNameFS (nameOccName name)-              in FieldLabel fs False name-            Just fs -> FieldLabel fs True name--        -- Called when we find no matching GREs after disambiguation but-        -- there are three situations where this happens.-        -- 1. There were none to begin with.-        -- 2. None of the matching ones were the parent but-        --  a. They were from an overloaded record field so we can report-        --     a better error-        --  b. The original lookup was actually ambiguous.-        --     For example, the case where overloading is off and two-        --     record fields are in scope from different record-        --     constructors, neither of which is the parent.-        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult-        noMatchingParentErr original_gres = do-          overload_ok <- xoptM LangExt.DuplicateRecordFields-          case original_gres of-            [] ->  return NameNotFound-            [g] -> return $ IncorrectParent parent-                              (gre_name g) (ppr $ gre_name g)-                              [p | Just p <- [getParent g]]-            gss@(g:_:_) ->-              if all isRecFldGRE gss && overload_ok-                then return $-                      IncorrectParent parent-                        (gre_name g)-                        (ppr $ expectJust "noMatchingParentErr" (greLabel g))-                        [p | x <- gss, Just p <- [getParent x]]-                else mkNameClashErr gss--        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult-        mkNameClashErr gres = do-          addNameClashErrRn rdr_name gres-          return (FoundName (gre_par (head gres)) (gre_name (head gres)))--        getParent :: GlobalRdrElt -> Maybe Name-        getParent (GRE { gre_par = p } ) =-          case p of-            ParentIs cur_parent -> Just cur_parent-            FldParent { par_is = cur_parent } -> Just cur_parent-            NoParent -> Nothing--        picked_gres :: [GlobalRdrElt] -> DisambigInfo-        -- For Unqual, find GREs that are in scope qualified or unqualified-        -- For Qual,   find GREs that are in scope with that qualification-        picked_gres gres-          | isUnqual rdr_name-          = mconcat (map right_parent gres)-          | otherwise-          = mconcat (map right_parent (pickGREs rdr_name gres))--        right_parent :: GlobalRdrElt -> DisambigInfo-        right_parent p-          = case getParent p of-               Just cur_parent-                  | parent == cur_parent -> DisambiguatedOccurrence p-                  | otherwise            -> NoOccurrence-               Nothing                   -> UniqueOccurrence p----- This domain specific datatype is used to record why we decided it was--- possible that a GRE could be exported with a parent.-data DisambigInfo-       = NoOccurrence-          -- The GRE could never be exported. It has the wrong parent.-       | UniqueOccurrence GlobalRdrElt-          -- The GRE has no parent. It could be a pattern synonym.-       | DisambiguatedOccurrence GlobalRdrElt-          -- The parent of the GRE is the correct parent-       | AmbiguousOccurrence [GlobalRdrElt]-          -- For example, two normal identifiers with the same name are in-          -- scope. They will both be resolved to "UniqueOccurrence" and the-          -- monoid will combine them to this failing case.--instance Outputable DisambigInfo where-  ppr NoOccurrence = text "NoOccurence"-  ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre-  ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre-  ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres--instance Semi.Semigroup DisambigInfo where-  -- This is the key line: We prefer disambiguated occurrences to other-  -- names.-  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'-  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'--  NoOccurrence <> m = m-  m <> NoOccurrence = m-  UniqueOccurrence g <> UniqueOccurrence g'-    = AmbiguousOccurrence [g, g']-  UniqueOccurrence g <> AmbiguousOccurrence gs-    = AmbiguousOccurrence (g:gs)-  AmbiguousOccurrence gs <> UniqueOccurrence g'-    = AmbiguousOccurrence (g':gs)-  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'-    = AmbiguousOccurrence (gs ++ gs')--instance Monoid DisambigInfo where-  mempty = NoOccurrence-  mappend = (Semi.<>)---- Lookup SubBndrOcc can never be ambiguous------ Records the result of looking up a child.-data ChildLookupResult-      = NameNotFound                --  We couldn't find a suitable name-      | IncorrectParent Name        -- Parent-                        Name        -- Name of thing we were looking for-                        SDoc        -- How to print the name-                        [Name]      -- List of possible parents-      | FoundName Parent Name       --  We resolved to a normal name-      | FoundFL FieldLabel          --  We resolved to a FL---- | Specialised version of msum for RnM ChildLookupResult-combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult-combineChildLookupResult [] = return NameNotFound-combineChildLookupResult (x:xs) = do-  res <- x-  case res of-    NameNotFound -> combineChildLookupResult xs-    _ -> return res--instance Outputable ChildLookupResult where-  ppr NameNotFound = text "NameNotFound"-  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n-  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls-  ppr (IncorrectParent p n td ns) = text "IncorrectParent"-                                  <+> hsep [ppr p, ppr n, td, ppr ns]--lookupSubBndrOcc :: Bool-                 -> Name     -- Parent-                 -> SDoc-                 -> RdrName-                 -> RnM (Either MsgDoc Name)--- Find all the things the rdr-name maps to--- and pick the one with the right parent namep-lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do-  res <--    lookupExactOrOrig rdr_name (FoundName NoParent) $-      -- This happens for built-in classes, see mod052 for example-      lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name-  case res of-    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))-    FoundName _p n -> return (Right n)-    FoundFL fl  ->  return (Right (flSelector fl))-    IncorrectParent {}-         -- See [Mismatched class methods and associated type families]-         -- in TcInstDecls.-      -> return $ Left (unknownSubordinateErr doc rdr_name)--{--Note [Family instance binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  data family F a-  data instance F T = X1 | X2--The 'data instance' decl has an *occurrence* of F (and T), and *binds*-X1 and X2.  (This is unlike a normal data type declaration which would-bind F too.)  So we want an AvailTC F [X1,X2].--Now consider a similar pair:-  class C a where-    data G a-  instance C S where-    data G S = Y1 | Y2--The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.--But there is a small complication: in an instance decl, we don't use-qualified names on the LHS; instead we use the class to disambiguate.-Thus:-  module M where-    import Blib( G )-    class C a where-      data G a-    instance C S where-      data G S = Y1 | Y2-Even though there are two G's in scope (M.G and Blib.G), the occurrence-of 'G' in the 'instance C S' decl is unambiguous, because C has only-one associated type called G. This is exactly what happens for methods,-and it is only consistent to do the same thing for types. That's the-role of the function lookupTcdName; the (Maybe Name) give the class of-the encloseing instance decl, if any.--Note [Looking up Exact RdrNames]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Exact RdrNames are generated by Template Haskell.  See Note [Binders-in Template Haskell] in Convert.--For data types and classes have Exact system Names in the binding-positions for constructors, TyCons etc.  For example-    [d| data T = MkT Int |]-when we splice in and Convert to HsSyn RdrName, we'll get-    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...-These System names are generated by Convert.thRdrName--But, constructors and the like need External Names, not System Names!-So we do the following-- * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a-   non-External Name, and make an External name for it. This is-   the name that goes in the GlobalRdrEnv-- * When looking up an occurrence of an Exact name, done in-   RnEnv.lookupExactOcc, we find the Name with the right unique in the-   GlobalRdrEnv, and use the one from the envt -- it will be an-   External Name in the case of the data type/constructor above.-- * Exact names are also use for purely local binders generated-   by TH, such as    \x_33. x_33-   Both binder and occurrence are Exact RdrNames.  The occurrence-   gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and-   misses, because lookupLocalRdrEnv always returns Nothing for-   an Exact Name.  Now we fall through to lookupExactOcc, which-   will find the Name is not in the GlobalRdrEnv, so we just use-   the Exact supplied Name.--Note [Splicing Exact names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the splice $(do { x <- newName "x"; return (VarE x) })-This will generate a (HsExpr RdrName) term that mentions the-Exact RdrName "x_56" (or whatever), but does not bind it.  So-when looking such Exact names we want to check that it's in scope,-otherwise the type checker will get confused.  To do this we need to-keep track of all the Names in scope, and the LocalRdrEnv does just that;-we consult it with RdrName.inLocalRdrEnvScope.--There is another wrinkle.  With TH and -XDataKinds, consider-   $( [d| data Nat = Zero-          data T = MkT (Proxy 'Zero)  |] )-After splicing, but before renaming we get this:-   data Nat_77{tc} = Zero_78{d}-   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )-The occurrence of 'Zero in the data type for T has the right unique,-but it has a TcClsName name-space in its OccName.  (This is set by-the ctxt_ns argument of Convert.thRdrName.)  When we check that is-in scope in the GlobalRdrEnv, we need to look up the DataName namespace-too.  (An alternative would be to make the GlobalRdrEnv also have-a Name -> GRE mapping.)--Note [Template Haskell ambiguity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The GlobalRdrEnv invariant says that if-  occ -> [gre1, ..., gren]-then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).-This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).--So how can we get multiple gres in lookupExactOcc_maybe?  Because in-TH we might use the same TH NameU in two different name spaces.-eg (#7241):-   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])-Here we generate a type constructor and data constructor with the same-unique, but different name spaces.--It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would-mean looking up the OccName in every name-space, just in case, and that-seems a bit brutal.  So it's just done here on lookup.  But we might-need to revisit that choice.--Note [Usage for sub-bndrs]-~~~~~~~~~~~~~~~~~~~~~~~~~~-If you have this-   import qualified M( C( f ) )-   instance M.C T where-     f x = x-then is the qualified import M.f used?  Obviously yes.-But the RdrName used in the instance decl is unqualified.  In effect,-we fill in the qualification by looking for f's whose class is M.C-But when adding to the UsedRdrNames we must make that qualification-explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".--So we make up a suitable (fake) RdrName.  But be careful-   import qualified M-   import M( C(f) )-   instance C T where-     f x = x-Here we want to record a use of 'f', not of 'M.f', otherwise-we'll miss the fact that the qualified import is redundant.-------------------------------------------------------              Occurrences-----------------------------------------------------}---lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)-lookupLocatedOccRn = wrapLocM lookupOccRn--lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)--- Just look in the local environment-lookupLocalOccRn_maybe rdr_name-  = do { local_env <- getLocalRdrEnv-       ; return (lookupLocalRdrEnv local_env rdr_name) }--lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))--- Just look in the local environment-lookupLocalOccThLvl_maybe name-  = do { lcl_env <- getLclEnv-       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }---- lookupOccRn looks up an occurrence of a RdrName-lookupOccRn :: RdrName -> RnM Name-lookupOccRn rdr_name-  = do { mb_name <- lookupOccRn_maybe rdr_name-       ; case mb_name of-           Just name -> return name-           Nothing   -> reportUnboundName rdr_name }---- Only used in one place, to rename pattern synonym binders.--- See Note [Renaming pattern synonym variables] in RnBinds-lookupLocalOccRn :: RdrName -> RnM Name-lookupLocalOccRn rdr_name-  = do { mb_name <- lookupLocalOccRn_maybe rdr_name-       ; case mb_name of-           Just name -> return name-           Nothing   -> unboundName WL_LocalOnly rdr_name }---- lookupPromotedOccRn looks up an optionally promoted RdrName.-lookupTypeOccRn :: RdrName -> RnM Name--- see Note [Demotion]-lookupTypeOccRn rdr_name-  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]-  = badVarInType rdr_name-  | otherwise-  = do { mb_name <- lookupOccRn_maybe rdr_name-       ; case mb_name of-             Just name -> return name-             Nothing   -> lookup_demoted rdr_name }--lookup_demoted :: RdrName -> RnM Name-lookup_demoted rdr_name-  | Just demoted_rdr <- demoteRdrName rdr_name-    -- Maybe it's the name of a *data* constructor-  = do { data_kinds <- xoptM LangExt.DataKinds-       ; star_is_type <- xoptM LangExt.StarIsType-       ; let star_info = starInfo star_is_type rdr_name-       ; if data_kinds-            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr-                    ; case mb_demoted_name of-                        Nothing -> unboundNameX WL_Any rdr_name star_info-                        Just demoted_name ->-                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $-                               addWarn-                                 (Reason Opt_WarnUntickedPromotedConstructors)-                                 (untickedPromConstrWarn demoted_name)-                             ; return demoted_name } }-            else do { -- We need to check if a data constructor of this name is-                      -- in scope to give good error messages. However, we do-                      -- not want to give an additional error if the data-                      -- constructor happens to be out of scope! See #13947.-                      mb_demoted_name <- discardErrs $-                                         lookupOccRn_maybe demoted_rdr-                    ; let suggestion | isJust mb_demoted_name = suggest_dk-                                     | otherwise = star_info-                    ; unboundNameX WL_Any rdr_name suggestion } }--  | otherwise-  = reportUnboundName rdr_name--  where-    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"-    untickedPromConstrWarn name =-      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot-      $$-      hsep [ text "Use"-           , quotes (char '\'' <> ppr name)-           , text "instead of"-           , quotes (ppr name) <> dot ]--badVarInType :: RdrName -> RnM Name-badVarInType rdr_name-  = do { addErr (text "Illegal promoted term variable in a type:"-                 <+> ppr rdr_name)-       ; return (mkUnboundNameRdr rdr_name) }--{- Note [Promoted variables in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#12686):-   x = True-   data Bad = Bad 'x--The parser treats the quote in 'x as saying "use the term-namespace", so we'll get (Bad x{v}), with 'x' in the-VarName namespace.  If we don't test for this, the renamer-will happily rename it to the x bound at top level, and then-the typecheck falls over because it doesn't have 'x' in scope-when kind-checking.--Note [Demotion]-~~~~~~~~~~~~~~~-When the user writes:-  data Nat = Zero | Succ Nat-  foo :: f Zero -> Int--'Zero' in the type signature of 'foo' is parsed as:-  HsTyVar ("Zero", TcClsName)--When the renamer hits this occurrence of 'Zero' it's going to realise-that it's not in scope. But because it is renaming a type, it knows-that 'Zero' might be a promoted data constructor, so it will demote-its namespace to DataName and do a second lookup.--The final result (after the renamer) will be:-  HsTyVar ("Zero", DataName)--}--lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName-                   -> RnM (Maybe r)-lookupOccRnX_maybe globalLookup wrapper rdr_name-  = runMaybeT . msum . map MaybeT $-      [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name-      , globalLookup rdr_name ]--lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)-lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id--lookupOccRn_overloaded :: Bool -> RdrName-                       -> RnM (Maybe (Either Name [Name]))-lookupOccRn_overloaded overload_ok-  = lookupOccRnX_maybe global_lookup Left-      where-        global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))-        global_lookup n =-          runMaybeT . msum . map MaybeT $-            [ lookupGlobalOccRn_overloaded overload_ok n-            , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]----lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)--- Looks up a RdrName occurrence in the top-level---   environment, including using lookupQualifiedNameGHCi---   for the GHCi case--- No filter function; does not report an error on failure--- Uses addUsedRdrName to record use and deprecations-lookupGlobalOccRn_maybe rdr_name =-  lookupExactOrOrig rdr_name Just $-    runMaybeT . msum . map MaybeT $-      [ fmap gre_name <$> lookupGreRn_maybe rdr_name-      , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]-                      -- This test is not expensive,-                      -- and only happens for failed lookups--lookupGlobalOccRn :: RdrName -> RnM Name--- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global--- environment.  Adds an error message if the RdrName is not in scope.--- You usually want to use "lookupOccRn" which also looks in the local--- environment.-lookupGlobalOccRn rdr_name-  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name-       ; case mb_name of-           Just n  -> return n-           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)-                         ; unboundName WL_Global rdr_name } }--lookupInfoOccRn :: RdrName -> RnM [Name]--- lookupInfoOccRn is intended for use in GHCi's ":info" command--- It finds all the GREs that RdrName could mean, not complaining--- about ambiguity, but rather returning them all--- C.f. #9881-lookupInfoOccRn rdr_name =-  lookupExactOrOrig rdr_name (:[]) $-    do { rdr_env <- getGlobalRdrEnv-       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)-       ; qual_ns <- lookupQualifiedNameGHCi rdr_name-       ; return (ns ++ (qual_ns `minusList` ns)) }---- | Like 'lookupOccRn_maybe', but with a more informative result if--- the 'RdrName' happens to be a record selector:------   * Nothing         -> name not in scope (no error reported)---   * Just (Left x)   -> name uniquely refers to x,---                        or there is a name clash (reported)---   * Just (Right xs) -> name refers to one or more record selectors;---                        if overload_ok was False, this list will be---                        a singleton.--lookupGlobalOccRn_overloaded :: Bool -> RdrName-                             -> RnM (Maybe (Either Name [Name]))-lookupGlobalOccRn_overloaded overload_ok rdr_name =-  lookupExactOrOrig rdr_name (Just . Left) $-     do  { res <- lookupGreRn_helper rdr_name-         ; case res of-                GreNotFound  -> return Nothing-                OneNameMatch gre -> do-                  let wrapper = if isRecFldGRE gre then Right . (:[]) else Left-                  return $ Just (wrapper (gre_name gre))-                MultipleNames gres  | all isRecFldGRE gres && overload_ok ->-                  -- Don't record usage for ambiguous selectors-                  -- until we know which is meant-                  return $ Just (Right (map gre_name gres))-                MultipleNames gres  -> do-                  addNameClashErrRn rdr_name gres-                  return (Just (Left (gre_name (head gres)))) }--------------------------------------------------------      Lookup in the Global RdrEnv of the module-----------------------------------------------------data GreLookupResult = GreNotFound-                     | OneNameMatch GlobalRdrElt-                     | MultipleNames [GlobalRdrElt]--lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)--- Look up the RdrName in the GlobalRdrEnv---   Exactly one binding: records it as "used", return (Just gre)---   No bindings:         return Nothing---   Many bindings:       report "ambiguous", return an arbitrary (Just gre)--- Uses addUsedRdrName to record use and deprecations-lookupGreRn_maybe rdr_name-  = do-      res <- lookupGreRn_helper rdr_name-      case res of-        OneNameMatch gre ->  return $ Just gre-        MultipleNames gres -> do-          traceRn "lookupGreRn_maybe:NameClash" (ppr gres)-          addNameClashErrRn rdr_name gres-          return $ Just (head gres)-        GreNotFound -> return Nothing--{---Note [ Unbound vs Ambiguous Names ]--lookupGreRn_maybe deals with failures in two different ways. If a name-is unbound then we return a `Nothing` but if the name is ambiguous-then we raise an error and return a dummy name.--The reason for this is that when we call `lookupGreRn_maybe` we are-speculatively looking for whatever we are looking up. If we don't find it,-then we might have been looking for the wrong thing and can keep trying.-On the other hand, if we find a clash then there is no way to recover as-we found the thing we were looking for but can no longer resolve which-the correct one is.--One example of this is in `lookupTypeOccRn` which first looks in the type-constructor namespace before looking in the data constructor namespace to-deal with `DataKinds`.--There is however, as always, one exception to this scheme. If we find-an ambiguous occurrence of a record selector and DuplicateRecordFields-is enabled then we defer the selection until the typechecker.---}------- Internal Function-lookupGreRn_helper :: RdrName -> RnM GreLookupResult-lookupGreRn_helper rdr_name-  = do  { env <- getGlobalRdrEnv-        ; case lookupGRE_RdrName rdr_name env of-            []    -> return GreNotFound-            [gre] -> do { addUsedGRE True gre-                        ; return (OneNameMatch gre) }-            gres  -> return (MultipleNames gres) }--lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)--- Used in export lists--- If not found or ambiguous, add error message, and fake with UnboundName--- Uses addUsedRdrName to record use and deprecations-lookupGreAvailRn rdr_name-  = do-      mb_gre <- lookupGreRn_helper rdr_name-      case mb_gre of-        GreNotFound ->-          do-            traceRn "lookupGreAvailRn" (ppr rdr_name)-            name <- unboundName WL_Global rdr_name-            return (name, avail name)-        MultipleNames gres ->-          do-            addNameClashErrRn rdr_name gres-            let unbound_name = mkUnboundNameRdr rdr_name-            return (unbound_name, avail unbound_name)-                        -- Returning an unbound name here prevents an error-                        -- cascade-        OneNameMatch gre ->-          return (gre_name gre, availFromGRE gre)---{--*********************************************************-*                                                      *-                Deprecations-*                                                      *-*********************************************************--Note [Handling of deprecations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* We report deprecations at each *occurrence* of the deprecated thing-  (see #5867)--* We do not report deprecations for locally-defined names. For a-  start, we may be exporting a deprecated thing. Also we may use a-  deprecated thing in the defn of another deprecated things.  We may-  even use a deprecated thing in the defn of a non-deprecated thing,-  when changing a module's interface.--* addUsedGREs: we do not report deprecations for sub-binders:-     - the ".." completion for records-     - the ".." in an export item 'T(..)'-     - the things exported by a module export 'module M'--}--addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()--- Remember use of in-scope data constructors (#7969)-addUsedDataCons rdr_env tycon-  = addUsedGREs [ gre-                | dc <- tyConDataCons tycon-                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]--addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()--- Called for both local and imported things--- Add usage *and* warn if deprecated-addUsedGRE warn_if_deprec gre-  = do { when warn_if_deprec (warnIfDeprecated gre)-       ; unless (isLocalGRE gre) $-         do { env <- getGblEnv-            ; traceRn "addUsedGRE" (ppr gre)-            ; updMutVar (tcg_used_gres env) (gre :) } }--addUsedGREs :: [GlobalRdrElt] -> RnM ()--- Record uses of any *imported* GREs--- Used for recording used sub-bndrs--- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]-addUsedGREs gres-  | null imp_gres = return ()-  | otherwise     = do { env <- getGblEnv-                       ; traceRn "addUsedGREs" (ppr imp_gres)-                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }-  where-    imp_gres = filterOut isLocalGRE gres--warnIfDeprecated :: GlobalRdrElt -> RnM ()-warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })-  | (imp_spec : _) <- iss-  = do { dflags <- getDynFlags-       ; this_mod <- getModule-       ; when (wopt Opt_WarnWarningsDeprecations dflags &&-               not (nameIsLocalOrFrom this_mod name)) $-                   -- See Note [Handling of deprecations]-         do { iface <- loadInterfaceForName doc name-            ; case lookupImpDeprec iface gre of-                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)-                                   (mk_msg imp_spec txt)-                Nothing  -> return () } }-  | otherwise-  = return ()-  where-    occ = greOccName gre-    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name-    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")--    mk_msg imp_spec txt-      = sep [ sep [ text "In the use of"-                    <+> pprNonVarNameSpace (occNameSpace occ)-                    <+> quotes (ppr occ)-                  , parens imp_msg <> colon ]-            , pprWarningTxtForMsg txt ]-      where-        imp_mod  = importSpecModule imp_spec-        imp_msg  = text "imported from" <+> ppr imp_mod <> extra-        extra | imp_mod == moduleName name_mod = Outputable.empty-              | otherwise = text ", but defined in" <+> ppr name_mod--lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt-lookupImpDeprec iface gre-  = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,-    case gre_par gre of                      -- or its parent, is warn'd-       ParentIs  p              -> mi_warn_fn (mi_final_exts iface) (nameOccName p)-       FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p)-       NoParent                 -> Nothing--{--Note [Used names with interface not loaded]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's (just) possible to find a used-Name whose interface hasn't been loaded:--a) It might be a WiredInName; in that case we may not load-   its interface (although we could).--b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger-   These are seen as "used" by the renamer (if -XRebindableSyntax)-   is on), but the typechecker may discard their uses-   if in fact the in-scope fromRational is GHC.Read.fromRational,-   (see tcPat.tcOverloadedLit), and the typechecker sees that the type-   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).-   In that obscure case it won't force the interface in.--In both cases we simply don't permit deprecations;-this is, after all, wired-in stuff.---*********************************************************-*                                                      *-                GHCi support-*                                                      *-*********************************************************--A qualified name on the command line can refer to any module at-all: we try to load the interface if we don't already have it, just-as if there was an "import qualified M" declaration for every-module.--For example, writing `Data.List.sort` will load the interface file for-`Data.List` as if the user had written `import qualified Data.List`.--If we fail we just return Nothing, rather than bleating-about "attempting to use module ‘D’ (./D.hs) which is not loaded"-which is what loadSrcInterface does.--It is enabled by default and disabled by the flag-`-fno-implicit-import-qualified`.--Note [Safe Haskell and GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We DON'T do this Safe Haskell as we need to check imports. We can-and should instead check the qualified import but at the moment-this requires some refactoring so leave as a TODO--}----lookupQualifiedNameGHCi :: RdrName -> RnM [Name]-lookupQualifiedNameGHCi rdr_name-  = -- We want to behave as we would for a source file import here,-    -- and respect hiddenness of modules/packages, hence loadSrcInterface.-    do { dflags  <- getDynFlags-       ; is_ghci <- getIsGHCi-       ; go_for_it dflags is_ghci }--  where-    go_for_it dflags is_ghci-      | Just (mod,occ) <- isQual_maybe rdr_name-      , is_ghci-      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour-      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]-      = do { res <- loadSrcInterface_maybe doc mod False Nothing-           ; case res of-                Succeeded iface-                  -> return [ name-                            | avail <- mi_exports iface-                            , name  <- availNames avail-                            , nameOccName name == occ ]--                _ -> -- Either we couldn't load the interface, or-                     -- we could but we didn't find the name in it-                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)-                        ; return [] } }--      | otherwise-      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)-           ; return [] }--    doc = text "Need to find" <+> ppr rdr_name--{--Note [Looking up signature names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-lookupSigOccRn is used for type signatures and pragmas-Is this valid?-  module A-        import M( f )-        f :: Int -> Int-        f x = x-It's clear that the 'f' in the signature must refer to A.f-The Haskell98 report does not stipulate this, but it will!-So we must treat the 'f' in the signature in the same way-as the binding occurrence of 'f', using lookupBndrRn--However, consider this case:-        import M( f )-        f :: Int -> Int-        g x = x-We don't want to say 'f' is out of scope; instead, we want to-return the imported 'f', so that later on the renamer will-correctly report "misplaced type sig".--Note [Signatures for top level things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-data HsSigCtxt = ... | TopSigCtxt NameSet | ....--* The NameSet says what is bound in this group of bindings.-  We can't use isLocalGRE from the GlobalRdrEnv, because of this:-       f x = x-       $( ...some TH splice... )-       f :: Int -> Int-  When we encounter the signature for 'f', the binding for 'f'-  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the-  signature is mis-placed--* For type signatures the NameSet should be the names bound by the-  value bindings; for fixity declarations, the NameSet should also-  include class sigs and record selectors--      infix 3 `f`          -- Yes, ok-      f :: C a => a -> a   -- No, not ok-      class C a where-        f :: a -> a--}--data HsSigCtxt-  = TopSigCtxt NameSet       -- At top level, binding these names-                             -- See Note [Signatures for top level things]-  | LocalBindCtxt NameSet    -- In a local binding, binding these names-  | ClsDeclCtxt   Name       -- Class decl for this class-  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method-                             -- bindings are for these methods-  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names-  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types-                             -- in the group--instance Outputable HsSigCtxt where-    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns-    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns-    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n-    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns-    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns-    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns--lookupSigOccRn :: HsSigCtxt-               -> Sig GhcPs-               -> Located RdrName -> RnM (Located Name)-lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)---- | Lookup a name in relation to the names in a 'HsSigCtxt'-lookupSigCtxtOccRn :: HsSigCtxt-                   -> SDoc         -- ^ description of thing we're looking up,-                                   -- like "type family"-                   -> Located RdrName -> RnM (Located Name)-lookupSigCtxtOccRn ctxt what-  = wrapLocM $ \ rdr_name ->-    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name-       ; case mb_name of-           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }-           Right name -> return name }--lookupBindGroupOcc :: HsSigCtxt-                   -> SDoc-                   -> RdrName -> RnM (Either MsgDoc Name)--- Looks up the RdrName, expecting it to resolve to one of the--- bound names passed in.  If not, return an appropriate error message------ See Note [Looking up signature names]-lookupBindGroupOcc ctxt what rdr_name-  | Just n <- isExact_maybe rdr_name-  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;-                              -- see Note [dataTcOccs and Exact Names]-      -- Maybe we should check the side conditions-      -- but it's a pain, and Exact things only show-      -- up when you know what you are doing--  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name-  = do { n' <- lookupOrig rdr_mod rdr_occ-       ; return (Right n') }--  | otherwise-  = case ctxt of-      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)-      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)-      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)-      LocalBindCtxt ns -> lookup_group ns-      ClsDeclCtxt  cls -> lookup_cls_op cls-      InstDeclCtxt ns  -> if uniqSetAny isUnboundName ns -- #16610-                          then return (Right $ mkUnboundNameRdr rdr_name)-                          else lookup_top (`elemNameSet` ns)-  where-    lookup_cls_op cls-      = lookupSubBndrOcc True cls doc rdr_name-      where-        doc = text "method of class" <+> quotes (ppr cls)--    lookup_top keep_me-      = do { env <- getGlobalRdrEnv-           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)-                 names_in_scope = -- If rdr_name lacks a binding, only-                                  -- recommend alternatives from related-                                  -- namespaces. See #17593.-                                  filter (\n -> nameSpacesRelated-                                                  (rdrNameSpace rdr_name)-                                                  (nameNameSpace n))-                                $ map gre_name-                                $ filter isLocalGRE-                                $ globalRdrEnvElts env-                 candidates_msg = candidates names_in_scope-           ; case filter (keep_me . gre_name) all_gres of-               [] | null all_gres -> bale_out_with candidates_msg-                  | otherwise     -> bale_out_with local_msg-               (gre:_)            -> return (Right (gre_name gre)) }--    lookup_group bound_names  -- Look in the local envt (not top level)-      = do { mname <- lookupLocalOccRn_maybe rdr_name-           ; env <- getLocalRdrEnv-           ; let candidates_msg = candidates $ localRdrEnvElts env-           ; case mname of-               Just n-                 | n `elemNameSet` bound_names -> return (Right n)-                 | otherwise                   -> bale_out_with local_msg-               Nothing                         -> bale_out_with candidates_msg }--    bale_out_with msg-        = return (Left (sep [ text "The" <+> what-                                <+> text "for" <+> quotes (ppr rdr_name)-                           , nest 2 $ text "lacks an accompanying binding"]-                       $$ nest 2 msg))--    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")-                           <+> quotes (ppr rdr_name) <+> text "is declared"--    -- Identify all similar names and produce a message listing them-    candidates :: [Name] -> MsgDoc-    candidates names_in_scope-      = case similar_names of-          []  -> Outputable.empty-          [n] -> text "Perhaps you meant" <+> pp_item n-          _   -> sep [ text "Perhaps you meant one of these:"-                     , nest 2 (pprWithCommas pp_item similar_names) ]-      where-        similar_names-          = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)-                        $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))-                              names_in_scope--        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x)-------------------lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]--- GHC extension: look up both the tycon and data con or variable.--- Used for top-level fixity signatures and deprecations.--- Complain if neither is in scope.--- See Note [Fixity signature lookup]-lookupLocalTcNames ctxt what rdr_name-  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)-       ; let (errs, names) = partitionEithers mb_gres-       ; when (null names) $ addErr (head errs) -- Bleat about one only-       ; return names }-  where-    lookup rdr = do { this_mod <- getModule-                    ; nameEither <- lookupBindGroupOcc ctxt what rdr-                    ; return (guard_builtin_syntax this_mod rdr nameEither) }--    -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233-    guard_builtin_syntax this_mod rdr (Right name)-      | Just _ <- isBuiltInOcc_maybe (occName rdr)-      , this_mod /= nameModule name-      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])-      | otherwise-      = Right (rdr, name)-    guard_builtin_syntax _ _ (Left err) = Left err--dataTcOccs :: RdrName -> [RdrName]--- Return both the given name and the same name promoted to the TcClsName--- namespace.  This is useful when we aren't sure which we are looking at.--- See also Note [dataTcOccs and Exact Names]-dataTcOccs rdr_name-  | isDataOcc occ || isVarOcc occ-  = [rdr_name, rdr_name_tc]-  | otherwise-  = [rdr_name]-  where-    occ = rdrNameOcc rdr_name-    rdr_name_tc =-      case rdr_name of-        -- The (~) type operator is always in scope, so we need a special case-        -- for it here, or else  :info (~)  fails in GHCi.-        -- See Note [eqTyCon (~) is built-in syntax]-        Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR-        _ -> setRdrNameSpace rdr_name tcName--{--Note [dataTcOccs and Exact Names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Exact RdrNames can occur in code generated by Template Haskell, and generally-those references are, well, exact. However, the TH `Name` type isn't expressive-enough to always track the correct namespace information, so we sometimes get-the right Unique but wrong namespace. Thus, we still have to do the double-lookup-for Exact RdrNames.--There is also an awkward situation for built-in syntax. Example in GHCi-   :info []-This parses as the Exact RdrName for nilDataCon, but we also want-the list type constructor.--Note that setRdrNameSpace on an Exact name requires the Name to be External,-which it always is for built in syntax.--}----{--************************************************************************-*                                                                      *-                        Rebindable names-        Dealing with rebindable syntax is driven by the-        Opt_RebindableSyntax dynamic flag.--        In "deriving" code we don't want to use rebindable syntax-        so we switch off the flag locally--*                                                                      *-************************************************************************--Haskell 98 says that when you say "3" you get the "fromInteger" from the-Standard Prelude, regardless of what is in scope.   However, to experiment-with having a language that is less coupled to the standard prelude, we're-trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"-happens to be in scope.  Then you can-        import Prelude ()-        import MyPrelude as Prelude-to get the desired effect.--At the moment this just happens for-  * fromInteger, fromRational on literals (in expressions and patterns)-  * negate (in expressions)-  * minus  (arising from n+k patterns)-  * "do" notation--We store the relevant Name in the HsSyn tree, in-  * HsIntegral/HsFractional/HsIsString-  * NegApp-  * NPlusKPat-  * HsDo-respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,-fromRationalName etc), but the renamer changes this to the appropriate user-name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.--We treat the original (standard) names as free-vars too, because the type checker-checks the type of the user thing against the type of the standard thing.--}--lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)--- Different to lookupSyntaxName because in the non-rebindable--- case we desugar directly rather than calling an existing function--- Hence the (Maybe (SyntaxExpr GhcRn)) return type-lookupIfThenElse-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not rebindable_on-         then return (Nothing, emptyFVs)-         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))-                 ; return ( Just (mkRnSyntaxExpr ite)-                          , unitFV ite ) } }--lookupSyntaxName' :: Name          -- ^ The standard name-                  -> RnM Name      -- ^ Possibly a non-standard name-lookupSyntaxName' std_name-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not rebindable_on then-           return std_name-         else-            -- Get the similarly named thing from the local environment-           lookupOccRn (mkRdrUnqual (nameOccName std_name)) }--lookupSyntaxName :: Name                             -- The standard name-                 -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard-                                                     -- name-lookupSyntaxName std_name-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not rebindable_on then-           return (mkRnSyntaxExpr std_name, emptyFVs)-         else-            -- Get the similarly named thing from the local environment-           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))-              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }--lookupSyntaxNames :: [Name]                         -- Standard names-     -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames-   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs-lookupSyntaxNames std_names-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not rebindable_on then-             return (map (HsVar noExtField . noLoc) std_names, emptyFVs)-        else-          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names-             ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }---- Error messages---opDeclErr :: RdrName -> SDoc-opDeclErr n-  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))-       2 (text "Use TypeOperators to declare operators in type and declarations")--badOrigBinding :: RdrName -> SDoc-badOrigBinding name-  | Just _ <- isBuiltInOcc_maybe occ-  = text "Illegal binding of built-in syntax:" <+> ppr occ-    -- Use an OccName here because we don't want to print Prelude.(,)-  | otherwise-  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"-    <+> ppr name-    -- This can happen when one tries to use a Template Haskell splice to-    -- define a top-level identifier with an already existing name, e.g.,-    ---    --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])-    ---    -- (See #13968.)-  where-    occ = rdrNameOcc $ filterCTuple name
− compiler/rename/RnExpr.hs 
@@ -1,2210 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[RnExpr]{Renaming of expressions}--Basically dependency analysis.--Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In-general, all of these functions return a renamed thing, and a set of-free variables.--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module RnExpr (-        rnLExpr, rnExpr, rnStmts-   ) where--#include "HsVersions.h"--import GhcPrelude--import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,-                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)-import GHC.Hs-import TcEnv            ( isBrackStage )-import TcRnMonad-import Module           ( getModule )-import RnEnv-import RnFixity-import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames-                        , bindLocalNames-                        , mapMaybeFvRn, mapFvRn-                        , warnUnusedLocalBinds, typeAppErr-                        , checkUnusedRecordWildcard )-import RnUnbound        ( reportUnboundName )-import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )-import RnTypes-import RnPat-import DynFlags-import PrelNames--import BasicTypes-import Name-import NameSet-import RdrName-import UniqSet-import Data.List-import Util-import ListSetOps       ( removeDups )-import ErrUtils-import Outputable-import SrcLoc-import FastString-import Control.Monad-import TysWiredIn       ( nilDataConName )-import qualified GHC.LanguageExtensions as LangExt--import Data.Ord-import Data.Array-import qualified Data.List.NonEmpty as NE--import Unique           ( mkVarOccUnique )--{--************************************************************************-*                                                                      *-\subsubsection{Expressions}-*                                                                      *-************************************************************************--}--rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)-rnExprs ls = rnExprs' ls emptyUniqSet- where-  rnExprs' [] acc = return ([], acc)-  rnExprs' (expr:exprs) acc =-   do { (expr', fvExpr) <- rnLExpr expr-        -- Now we do a "seq" on the free vars because typically it's small-        -- or empty, especially in very long lists of constants-      ; let  acc' = acc `plusFV` fvExpr-      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'-      ; return (expr':exprs', fvExprs) }---- Variables. We look up the variable and return the resulting name.--rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)-rnLExpr = wrapLocFstM rnExpr--rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)--finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)--- Separated from rnExpr because it's also used--- when renaming infix expressions-finishHsVar (L l name)- = do { this_mod <- getModule-      ; when (nameIsLocalOrFrom this_mod name) $-        checkThLocalName name-      ; return (HsVar noExtField (L l name), unitFV name) }--rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v- = do { if isUnqual v-        then -- Treat this as a "hole"-             -- Do not fail right now; instead, return HsUnboundVar-             -- and let the type checker report the error-             return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)--        else -- Fail immediately (qualified name)-             do { n <- reportUnboundName v-                ; return (HsVar noExtField (noLoc n), emptyFVs) } }--rnExpr (HsVar _ (L l v))-  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields-       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v-       ; dflags <- getDynFlags-       ; case mb_name of {-           Nothing -> rnUnboundVar v ;-           Just (Left name)-              | name == nilDataConName -- Treat [] as an ExplicitList, so that-                                       -- OverloadedLists works correctly-                                       -- Note [Empty lists] in GHC.Hs.Expr-              , xopt LangExt.OverloadedLists dflags-              -> rnExpr (ExplicitList noExtField Nothing [])--              | otherwise-              -> finishHsVar (L l name) ;-            Just (Right [s]) ->-              return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ;-           Just (Right fs@(_:_:_)) ->-              return ( HsRecFld noExtField (Ambiguous noExtField (L l v))-                     , mkFVs fs);-           Just (Right [])         -> panic "runExpr/HsVar" } }--rnExpr (HsIPVar x v)-  = return (HsIPVar x v, emptyFVs)--rnExpr (HsUnboundVar x v)-  = return (HsUnboundVar x v, emptyFVs)--rnExpr (HsOverLabel x _ v)-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if rebindable_on-         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))-                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }-         else return (HsOverLabel x Nothing v, emptyFVs) }--rnExpr (HsLit x lit@(HsString src s))-  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings-       ; if opt_OverloadedStrings then-            rnExpr (HsOverLit x (mkHsIsString src s))-         else do {-            ; rnLit lit-            ; return (HsLit x (convertLit lit), emptyFVs) } }--rnExpr (HsLit x lit)-  = do { rnLit lit-       ; return (HsLit x(convertLit lit), emptyFVs) }--rnExpr (HsOverLit x lit)-  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]-       ; case mb_neg of-              Nothing -> return (HsOverLit x lit', fvs)-              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))-                                 , fvs ) }--rnExpr (HsApp x fun arg)-  = do { (fun',fvFun) <- rnLExpr fun-       ; (arg',fvArg) <- rnLExpr arg-       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }--rnExpr (HsAppType x fun arg)-  = do { type_app <- xoptM LangExt.TypeApplications-       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg-       ; (fun',fvFun) <- rnLExpr fun-       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg-       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }--rnExpr (OpApp _ e1 op e2)-  = do  { (e1', fv_e1) <- rnLExpr e1-        ; (e2', fv_e2) <- rnLExpr e2-        ; (op', fv_op) <- rnLExpr op--        -- Deal with fixity-        -- When renaming code synthesised from "deriving" declarations-        -- we used to avoid fixity stuff, but we can't easily tell any-        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv-        -- should prevent bad things happening.-        ; fixity <- case op' of-              L _ (HsVar _ (L _ n)) -> lookupFixityRn n-              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f-              _ -> return (Fixity NoSourceText minPrecedence InfixL)-                   -- c.f. lookupFixity for unbound--        ; final_e <- mkOpAppRn e1' op' fixity e2'-        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }--rnExpr (NegApp _ e _)-  = do { (e', fv_e)         <- rnLExpr e-       ; (neg_name, fv_neg) <- lookupSyntaxName negateName-       ; final_e            <- mkNegAppRn e' neg_name-       ; return (final_e, fv_e `plusFV` fv_neg) }----------------------------------------------- Template Haskell extensions-rnExpr e@(HsBracket _ br_body) = rnBracket e br_body--rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice--------------------------------------------------      Sections--- See Note [Parsing sections] in Parser.y-rnExpr (HsPar x (L loc (section@(SectionL {}))))-  = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }--rnExpr (HsPar x (L loc (section@(SectionR {}))))-  = do  { (section', fvs) <- rnSection section-        ; return (HsPar x (L loc section'), fvs) }--rnExpr (HsPar x e)-  = do  { (e', fvs_e) <- rnLExpr e-        ; return (HsPar x e', fvs_e) }--rnExpr expr@(SectionL {})-  = do  { addErr (sectionErr expr); rnSection expr }-rnExpr expr@(SectionR {})-  = do  { addErr (sectionErr expr); rnSection expr }------------------------------------------------rnExpr (HsPragE x prag expr)-  = do { (expr', fvs_expr) <- rnLExpr expr-       ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }-  where-    rn_prag :: HsPragE GhcPs -> HsPragE GhcRn-    rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann-    rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl-    rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo-    rn_prag (XHsPragE x) = noExtCon x--rnExpr (HsLam x matches)-  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches-       ; return (HsLam x matches', fvMatch) }--rnExpr (HsLamCase x matches)-  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches-       ; return (HsLamCase x matches', fvs_ms) }--rnExpr (HsCase x expr matches)-  = do { (new_expr, e_fvs) <- rnLExpr expr-       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches-       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }--rnExpr (HsLet x (L l binds) expr)-  = rnLocalBindsAndThen binds $ \binds' _ -> do-      { (expr',fvExpr) <- rnLExpr expr-      ; return (HsLet x (L l binds') expr', fvExpr) }--rnExpr (HsDo x do_or_lc (L l stmts))-  = do  { ((stmts', _), fvs) <--           rnStmtsWithPostProcessing do_or_lc rnLExpr-             postProcessStmtsForApplicativeDo stmts-             (\ _ -> return ((), emptyFVs))-        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }--rnExpr (ExplicitList x _  exps)-  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists-        ; (exps', fvs) <- rnExprs exps-        ; if opt_OverloadedLists-           then do {-            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName-            ; return (ExplicitList x (Just from_list_n_name) exps'-                     , fvs `plusFV` fvs') }-           else-            return  (ExplicitList x Nothing exps', fvs) }--rnExpr (ExplicitTuple x tup_args boxity)-  = do { checkTupleSection tup_args-       ; checkTupSize (length tup_args)-       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args-       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }-  where-    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e-                                      ; return (L l (Present x e'), fvs) }-    rnTupArg (L l (Missing _)) = return (L l (Missing noExtField)-                                        , emptyFVs)-    rnTupArg (L _ (XTupArg nec)) = noExtCon nec--rnExpr (ExplicitSum x alt arity expr)-  = do { (expr', fvs) <- rnLExpr expr-       ; return (ExplicitSum x alt arity expr', fvs) }--rnExpr (RecordCon { rcon_con_name = con_id-                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id-       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds-       ; (flds', fvss) <- mapAndUnzipM rn_field flds-       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }-       ; return (RecordCon { rcon_ext = noExtField-                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }-                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }-  where-    mk_hs_var l n = HsVar noExtField (L l n)-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }--rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })-  = do  { (expr', fvExpr) <- rnLExpr expr-        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds-        ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr'-                            , rupd_flds = rbinds' }-                 , fvExpr `plusFV` fvRbinds) }--rnExpr (ExprWithTySig _ expr pty)-  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty-        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $-                             rnLExpr expr-        ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }--rnExpr (HsIf x _ p b1 b2)-  = do { (p', fvP) <- rnLExpr p-       ; (b1', fvB1) <- rnLExpr b1-       ; (b2', fvB2) <- rnLExpr b2-       ; (mb_ite, fvITE) <- lookupIfThenElse-       ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }--rnExpr (HsMultiIf x alts)-  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts-       -- ; return (HsMultiIf ty alts', fvs) }-       ; return (HsMultiIf x alts', fvs) }--rnExpr (ArithSeq x _ seq)-  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists-       ; (new_seq, fvs) <- rnArithSeq seq-       ; if opt_OverloadedLists-           then do {-            ; (from_list_name, fvs') <- lookupSyntaxName fromListName-            ; return (ArithSeq x (Just from_list_name) new_seq-                     , fvs `plusFV` fvs') }-           else-            return (ArithSeq x Nothing new_seq, fvs) }--{--************************************************************************-*                                                                      *-        Static values-*                                                                      *-************************************************************************--For the static form we check that it is not used in splices.-We also collect the free variables of the term which come from-this module. See Note [Grand plan for static forms] in StaticPtrTable.--}--rnExpr e@(HsStatic _ expr) = do-    -- Normally, you wouldn't be able to construct a static expression without-    -- first enabling -XStaticPointers in the first place, since that extension-    -- is what makes the parser treat `static` as a keyword. But this is not a-    -- sufficient safeguard, as one can construct static expressions by another-    -- mechanism: Template Haskell (see #14204). To ensure that GHC is-    -- absolutely prepared to cope with static forms, we check for-    -- -XStaticPointers here as well.-    unlessXOptM LangExt.StaticPointers $-      addErr $ hang (text "Illegal static expression:" <+> ppr e)-                  2 (text "Use StaticPointers to enable this extension")-    (expr',fvExpr) <- rnLExpr expr-    stage <- getStage-    case stage of-      Splice _ -> addErr $ sep-             [ text "static forms cannot be used in splices:"-             , nest 2 $ ppr e-             ]-      _ -> return ()-    mod <- getModule-    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr-    return (HsStatic fvExpr' expr', fvExpr)--{--************************************************************************-*                                                                      *-        Arrow notation-*                                                                      *-************************************************************************--}--rnExpr (HsProc x pat body)-  = newArrowScope $-    rnPat ProcExpr pat $ \ pat' -> do-      { (body',fvBody) <- rnCmdTop body-      ; return (HsProc x pat' body', fvBody) }--rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)-        -- HsWrap--------------------------- See Note [Parsing sections] in Parser.y-rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)-rnSection section@(SectionR x op expr)-  = do  { (op', fvs_op)     <- rnLExpr op-        ; (expr', fvs_expr) <- rnLExpr expr-        ; checkSectionPrec InfixR section op' expr'-        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }--rnSection section@(SectionL x expr op)-  = do  { (expr', fvs_expr) <- rnLExpr expr-        ; (op', fvs_op)     <- rnLExpr op-        ; checkSectionPrec InfixL section op' expr'-        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }--rnSection other = pprPanic "rnSection" (ppr other)--{--************************************************************************-*                                                                      *-        Arrow commands-*                                                                      *-************************************************************************--}--rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)-rnCmdArgs [] = return ([], emptyFVs)-rnCmdArgs (arg:args)-  = do { (arg',fvArg) <- rnCmdTop arg-       ; (args',fvArgs) <- rnCmdArgs args-       ; return (arg':args', fvArg `plusFV` fvArgs) }--rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)-rnCmdTop = wrapLocFstM rnCmdTop'- where-  rnCmdTop' (HsCmdTop _ cmd)-   = do { (cmd', fvCmd) <- rnLCmd cmd-        ; let cmd_names = [arrAName, composeAName, firstAName] ++-                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))-        -- Generate the rebindable syntax for the monad-        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names--        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',-                  fvCmd `plusFV` cmd_fvs) }-  rnCmdTop' (XCmdTop nec) = noExtCon nec--rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)-rnLCmd = wrapLocFstM rnCmd--rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)--rnCmd (HsCmdArrApp x arrow arg ho rtl)-  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)-       ; (arg',fvArg) <- rnLExpr arg-       ; return (HsCmdArrApp x arrow' arg' ho rtl,-                 fvArrow `plusFV` fvArg) }-  where-    select_arrow_scope tc = case ho of-        HsHigherOrderApp -> tc-        HsFirstOrderApp  -> escapeArrowScope tc-        -- See Note [Escaping the arrow scope] in TcRnTypes-        -- Before renaming 'arrow', use the environment of the enclosing-        -- proc for the (-<) case.-        -- Local bindings, inside the enclosing proc, are not in scope-        -- inside 'arrow'.  In the higher-order case (-<<), they are.---- infix form-rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])-  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)-       ; let L _ (HsVar _ (L _ op_name)) = op'-       ; (arg1',fv_arg1) <- rnCmdTop arg1-       ; (arg2',fv_arg2) <- rnCmdTop arg2-        -- Deal with fixity-       ; fixity <- lookupFixityRn op_name-       ; final_e <- mkOpFormRn arg1' op' fixity arg2'-       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }--rnCmd (HsCmdArrForm x op f fixity cmds)-  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)-       ; (cmds',fvCmds) <- rnCmdArgs cmds-       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }--rnCmd (HsCmdApp x fun arg)-  = do { (fun',fvFun) <- rnLCmd  fun-       ; (arg',fvArg) <- rnLExpr arg-       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }--rnCmd (HsCmdLam x matches)-  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches-       ; return (HsCmdLam x matches', fvMatch) }--rnCmd (HsCmdPar x e)-  = do  { (e', fvs_e) <- rnLCmd e-        ; return (HsCmdPar x e', fvs_e) }--rnCmd (HsCmdCase x expr matches)-  = do { (new_expr, e_fvs) <- rnLExpr expr-       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches-       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }--rnCmd (HsCmdIf x _ p b1 b2)-  = do { (p', fvP) <- rnLExpr p-       ; (b1', fvB1) <- rnLCmd b1-       ; (b2', fvB2) <- rnLCmd b2-       ; (mb_ite, fvITE) <- lookupIfThenElse-       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}--rnCmd (HsCmdLet x (L l binds) cmd)-  = rnLocalBindsAndThen binds $ \ binds' _ -> do-      { (cmd',fvExpr) <- rnLCmd cmd-      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }--rnCmd (HsCmdDo x (L l stmts))-  = do  { ((stmts', _), fvs) <--            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))-        ; return ( HsCmdDo x (L l stmts'), fvs ) }--rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)-rnCmd     (XCmd nec)     = noExtCon nec------------------------------------------------------type CmdNeeds = FreeVars        -- Only inhabitants are-                                --      appAName, choiceAName, loopAName---- find what methods the Cmd needs (loop, choice, apply)-methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds-methodNamesLCmd = methodNamesCmd . unLoc--methodNamesCmd :: HsCmd GhcRn -> CmdNeeds--methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)-  = emptyFVs-methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)-  = unitFV appAName-methodNamesCmd (HsCmdArrForm {}) = emptyFVs-methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd--methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c--methodNamesCmd (HsCmdIf _ _ _ c1 c2)-  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName--methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c-methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts-methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c-methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match--methodNamesCmd (HsCmdCase _ _ matches)-  = methodNamesMatch matches `addOneFV` choiceAName--methodNamesCmd (XCmd nec) = noExtCon nec----methodNamesCmd _ = emptyFVs-   -- Other forms can't occur in commands, but it's not convenient-   -- to error here so we just do what's convenient.-   -- The type checker will complain later------------------------------------------------------methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars-methodNamesMatch (MG { mg_alts = L _ ms })-  = plusFVs (map do_one ms)- where-    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss-    do_one (L _ (XMatch nec)) = noExtCon nec-methodNamesMatch (XMatchGroup nec) = noExtCon nec------------------------------------------------------ gaw 2004-methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars-methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)-methodNamesGRHSs (XGRHSs nec) = noExtCon nec-----------------------------------------------------methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds-methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs-methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec------------------------------------------------------methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars-methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)------------------------------------------------------methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars-methodNamesLStmt = methodNamesStmt . unLoc--methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars-methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd-methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd-methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd-methodNamesStmt (RecStmt { recS_stmts = stmts }) =-  methodNamesStmts stmts `addOneFV` loopAName-methodNamesStmt (LetStmt {})                   = emptyFVs-methodNamesStmt (ParStmt {})                   = emptyFVs-methodNamesStmt (TransStmt {})                 = emptyFVs-methodNamesStmt ApplicativeStmt{}              = emptyFVs-   -- ParStmt and TransStmt can't occur in commands, but it's not-   -- convenient to error here so we just do what's convenient-methodNamesStmt (XStmtLR nec) = noExtCon nec--{--************************************************************************-*                                                                      *-        Arithmetic sequences-*                                                                      *-************************************************************************--}--rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)-rnArithSeq (From expr)- = do { (expr', fvExpr) <- rnLExpr expr-      ; return (From expr', fvExpr) }--rnArithSeq (FromThen expr1 expr2)- = do { (expr1', fvExpr1) <- rnLExpr expr1-      ; (expr2', fvExpr2) <- rnLExpr expr2-      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }--rnArithSeq (FromTo expr1 expr2)- = do { (expr1', fvExpr1) <- rnLExpr expr1-      ; (expr2', fvExpr2) <- rnLExpr expr2-      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }--rnArithSeq (FromThenTo expr1 expr2 expr3)- = do { (expr1', fvExpr1) <- rnLExpr expr1-      ; (expr2', fvExpr2) <- rnLExpr expr2-      ; (expr3', fvExpr3) <- rnLExpr expr3-      ; return (FromThenTo expr1' expr2' expr3',-                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }--{--************************************************************************-*                                                                      *-\subsubsection{@Stmt@s: in @do@ expressions}-*                                                                      *-************************************************************************--}--{--Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both ApplicativeDo and RecursiveDo need to create tuples not-present in the source text.--For ApplicativeDo we create:--  (a,b,c) <- (\c b a -> (a,b,c)) <$>--For RecursiveDo we create:--  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))--The order of the components in those tuples needs to be stable-across recompilations, otherwise they can get optimized differently-and we end up with incompatible binaries.-To get a stable order we use nameSetElemsStable.-See Note [Deterministic UniqFM] to learn more about nondeterminism.--}---- | Rename some Stmts-rnStmts :: Outputable (body GhcPs)-        => HsStmtContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-           -- ^ How to rename the body of each statement (e.g. rnLExpr)-        -> [LStmt GhcPs (Located (body GhcPs))]-           -- ^ Statements-        -> ([Name] -> RnM (thing, FreeVars))-           -- ^ if these statements scope over something, this renames it-           -- and returns the result.-        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)-rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts---- | like 'rnStmts' but applies a post-processing step to the renamed Stmts-rnStmtsWithPostProcessing-        :: Outputable (body GhcPs)-        => HsStmtContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-           -- ^ How to rename the body of each statement (e.g. rnLExpr)-        -> (HsStmtContext Name-              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]-              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))-           -- ^ postprocess the statements-        -> [LStmt GhcPs (Located (body GhcPs))]-           -- ^ Statements-        -> ([Name] -> RnM (thing, FreeVars))-           -- ^ if these statements scope over something, this renames it-           -- and returns the result.-        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)-rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside- = do { ((stmts', thing), fvs) <--          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside-      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'-      ; return ((pp_stmts, thing), fvs `plusFV` fvs')-      }---- | maybe rearrange statements according to the ApplicativeDo transformation-postProcessStmtsForApplicativeDo-  :: HsStmtContext Name-  -> [(ExprLStmt GhcRn, FreeVars)]-  -> RnM ([ExprLStmt GhcRn], FreeVars)-postProcessStmtsForApplicativeDo ctxt stmts-  = do {-       -- rearrange the statements using ApplicativeStmt if-       -- -XApplicativeDo is on.  Also strip out the FreeVars attached-       -- to each Stmt body.-         ado_is_on <- xoptM LangExt.ApplicativeDo-       ; let is_do_expr | DoExpr <- ctxt = True-                        | otherwise = False-       -- don't apply the transformation inside TH brackets, because-       -- DsMeta does not handle ApplicativeDo.-       ; in_th_bracket <- isBrackStage <$> getStage-       ; if ado_is_on && is_do_expr && not in_th_bracket-            then do { traceRn "ppsfa" (ppr stmts)-                    ; rearrangeForApplicativeDo ctxt stmts }-            else noPostProcessStmts ctxt stmts }---- | strip the FreeVars annotations from statements-noPostProcessStmts-  :: HsStmtContext Name-  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]-  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)-noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)---rnStmtsWithFreeVars :: Outputable (body GhcPs)-        => HsStmtContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> [LStmt GhcPs (Located (body GhcPs))]-        -> ([Name] -> RnM (thing, FreeVars))-        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)-               , FreeVars)--- Each Stmt body is annotated with its FreeVars, so that--- we can rearrange statements for ApplicativeDo.------ Variables bound by the Stmts, and mentioned in thing_inside,--- do not appear in the result FreeVars--rnStmtsWithFreeVars ctxt _ [] thing_inside-  = do { checkEmptyStmts ctxt-       ; (thing, fvs) <- thing_inside []-       ; return (([], thing), fvs) }--rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo-  = -- Behave like do { rec { ...all but last... }; last }-    do { ((stmts1, (stmts2, thing)), fvs)-           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->-              do { last_stmt' <- checkLastStmt MDoExpr last_stmt-                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }-        ; return (((stmts1 ++ stmts2), thing), fvs) }-  where-    Just (all_but_last, last_stmt) = snocView stmts--rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside-  | null lstmts-  = setSrcSpan loc $-    do { lstmt' <- checkLastStmt ctxt lstmt-       ; rnStmt ctxt rnBody lstmt' thing_inside }--  | otherwise-  = do { ((stmts1, (stmts2, thing)), fvs)-            <- setSrcSpan loc                         $-               do { checkStmt ctxt lstmt-                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->-                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->-                    thing_inside (bndrs1 ++ bndrs2) }-        ; return (((stmts1 ++ stmts2), thing), fvs) }--------------------------{--Note [Failing pattern matches in Stmts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Many things desugar to HsStmts including monadic things like `do` and `mdo`-statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an-exhaustive list). How we deal with pattern match failure is context-dependent.-- * In the case of list comprehensions and pattern guards we don't need any 'fail'-   function; the desugarer ignores the fail function field of 'BindStmt' entirely.- * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo-   expressions) we want pattern match failure to be desugared to the appropriate-   'fail' function (either that of Monad or MonadFail, depending on whether-   -XMonadFailDesugaring is enabled.)--At one point we failed to make this distinction, leading to #11216.--}--rnStmt :: Outputable (body GhcPs)-       => HsStmtContext Name-       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-          -- ^ How to rename the body of the statement-       -> LStmt GhcPs (Located (body GhcPs))-          -- ^ The statement-       -> ([Name] -> RnM (thing, FreeVars))-          -- ^ Rename the stuff that this statement scopes over-       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)-              , FreeVars)--- Variables bound by the Stmt, and mentioned in thing_inside,--- do not appear in the result FreeVars--rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside-  = do  { (body', fv_expr) <- rnBody body-        ; (ret_op, fvs1) <- if isMonadCompContext ctxt-                            then lookupStmtName ctxt returnMName-                            else return (noSyntaxExpr, emptyFVs)-                            -- The 'return' in a LastStmt is used only-                            -- for MonadComp; and we don't want to report-                            -- "non in scope: return" in other cases-                            -- #15607--        ; (thing,  fvs3) <- thing_inside []-        ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)]-                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }--rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside-  = do  { (body', fv_expr) <- rnBody body-        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName--        ; (guard_op, fvs2) <- if isComprehensionContext ctxt-                              then lookupStmtName ctxt guardMName-                              else return (noSyntaxExpr, emptyFVs)-                              -- Only list/monad comprehensions use 'guard'-                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]-                              -- Here "gd" is a guard--        ; (thing, fvs3)    <- thing_inside []-        ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)]-                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }--rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside-  = do  { (body', fv_expr) <- rnBody body-                -- The binders do not scope over the expression-        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName--        ; (fail_op, fvs2) <- monadFailOp pat ctxt--        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do-        { (thing, fvs3) <- thing_inside (collectPatBinders pat')-        ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op)-                     , fv_expr )]-                  , thing),-                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}-       -- fv_expr shouldn't really be filtered by the rnPatsAndThen-        -- but it does not matter because the names are unique--rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside-  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do-        { (thing, fvs) <- thing_inside (collectLocalBinders binds')-        ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing)-                 , fvs) }  }--rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside-  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName-        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName-        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName-        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op-                                                , recS_mfix_fn = mfix_op-                                                , recS_bind_fn = bind_op }--        -- Step1: Bring all the binders of the mdo into scope-        -- (Remember that this also removes the binders from the-        -- finally-returned free-vars.)-        -- And rename each individual stmt, making a-        -- singleton segment.  At this stage the FwdRefs field-        -- isn't finished: it's empty for all except a BindStmt-        -- for which it's the fwd refs within the bind itself-        -- (This set may not be empty, because we're in a recursive-        -- context.)-        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do-        { let bndrs = nameSetElemsStable $-                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))-                              emptyNameSet-                              segs-          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-        ; (thing, fvs_later) <- thing_inside bndrs-        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later-        -- We aren't going to try to group RecStmts with-        -- ApplicativeDo, so attaching empty FVs is fine.-        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)-                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }--rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside-  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName-        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName-        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName-        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside-        ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)-                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }--rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form-                              , trS_using = using })) thing_inside-  = do { -- Rename the 'using' expression in the context before the transform is begun-         (using', fvs1) <- rnLExpr using--         -- Rename the stmts and the 'by' expression-         -- Keep track of the variables mentioned in the 'by' expression-       ; ((stmts', (by', used_bndrs, thing)), fvs2)-             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->-                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by-                   ; (thing, fvs_thing) <- thing_inside bndrs-                   ; let fvs = fvs_by `plusFV` fvs_thing-                         used_bndrs = filter (`elemNameSet` fvs) bndrs-                         -- The paper (Fig 5) has a bug here; we must treat any free variable-                         -- of the "thing inside", **or of the by-expression**, as used-                   ; return ((by', used_bndrs, thing), fvs) }--       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions-       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName-       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName-       ; (fmap_op,   fvs5) <- case form of-                                ThenForm -> return (noExpr, emptyFVs)-                                _        -> lookupStmtNamePoly ctxt fmapName--       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3-                             `plusFV` fvs4 `plusFV` fvs5-             bndr_map = used_bndrs `zip` used_bndrs-             -- See Note [TransStmt binder map] in GHC.Hs.Expr--       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)-       ; return (([(L loc (TransStmt { trS_ext = noExtField-                                    , trS_stmts = stmts', trS_bndrs = bndr_map-                                    , trS_by = by', trS_using = using', trS_form = form-                                    , trS_ret = return_op, trS_bind = bind_op-                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }--rnStmt _ _ (L _ ApplicativeStmt{}) _ =-  panic "rnStmt: ApplicativeStmt"--rnStmt _ _ (L _ (XStmtLR nec)) _ =-  noExtCon nec--rnParallelStmts :: forall thing. HsStmtContext Name-                -> SyntaxExpr GhcRn-                -> [ParStmtBlock GhcPs GhcPs]-                -> ([Name] -> RnM (thing, FreeVars))-                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)--- Note [Renaming parallel Stmts]-rnParallelStmts ctxt return_op segs thing_inside-  = do { orig_lcl_env <- getLocalRdrEnv-       ; rn_segs orig_lcl_env [] segs }-  where-    rn_segs :: LocalRdrEnv-            -> [Name] -> [ParStmtBlock GhcPs GhcPs]-            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)-    rn_segs _ bndrs_so_far []-      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far-           ; mapM_ dupErr dups-           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')-           ; return (([], thing), fvs) }--    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)-      = do { ((stmts', (used_bndrs, segs', thing)), fvs)-                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->-                       setLocalRdrEnv env       $ do-                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs-                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs-                       ; return ((used_bndrs, segs', thing), fvs) }--           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op-           ; return ((seg':segs', thing), fvs) }-    rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec--    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2-    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"-                    <+> quotes (ppr (NE.head vs)))--lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)--- Like lookupSyntaxName, but respects contexts-lookupStmtName ctxt n-  | rebindableContext ctxt-  = lookupSyntaxName n-  | otherwise-  = return (mkRnSyntaxExpr n, emptyFVs)--lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)-lookupStmtNamePoly ctxt name-  | rebindableContext ctxt-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if rebindable_on-         then do { fm <- lookupOccRn (nameRdrName name)-                 ; return (HsVar noExtField (noLoc fm), unitFV fm) }-         else not_rebindable }-  | otherwise-  = not_rebindable-  where-    not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs)---- | Is this a context where we respect RebindableSyntax?--- but ListComp are never rebindable--- Neither is ArrowExpr, which has its own desugarer in DsArrows-rebindableContext :: HsStmtContext Name -> Bool-rebindableContext ctxt = case ctxt of-  ListComp        -> False-  ArrowExpr       -> False-  PatGuard {}     -> False--  DoExpr          -> True-  MDoExpr         -> True-  MonadComp       -> True-  GhciStmtCtxt    -> True   -- I suppose?--  ParStmtCtxt   c -> rebindableContext c     -- Look inside to-  TransStmtCtxt c -> rebindableContext c     -- the parent context--{--Note [Renaming parallel Stmts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Renaming parallel statements is painful.  Given, say-     [ a+c | a <- as, bs <- bss-           | c <- bs, a <- ds ]-Note that-  (a) In order to report "Defined but not used" about 'bs', we must-      rename each group of Stmts with a thing_inside whose FreeVars-      include at least {a,c}--  (b) We want to report that 'a' is illegally bound in both branches--  (c) The 'bs' in the second group must obviously not be captured by-      the binding in the first group--To satisfy (a) we nest the segements.-To satisfy (b) we check for duplicates just before thing_inside.-To satisfy (c) we reset the LocalRdrEnv each time.--************************************************************************-*                                                                      *-\subsubsection{mdo expressions}-*                                                                      *-************************************************************************--}--type FwdRefs = NameSet-type Segment stmts = (Defs,-                      Uses,     -- May include defs-                      FwdRefs,  -- A subset of uses that are-                                --   (a) used before they are bound in this segment, or-                                --   (b) used here, and bound in subsequent segments-                      stmts)    -- Either Stmt or [Stmt]----- wrapper that does both the left- and right-hand sides-rnRecStmtsAndThen :: Outputable (body GhcPs) =>-                     (Located (body GhcPs)-                  -> RnM (Located (body GhcRn), FreeVars))-                  -> [LStmt GhcPs (Located (body GhcPs))]-                         -- assumes that the FreeVars returned includes-                         -- the FreeVars of the Segments-                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]-                      -> RnM (a, FreeVars))-                  -> RnM (a, FreeVars)-rnRecStmtsAndThen rnBody s cont-  = do  { -- (A) Make the mini fixity env for all of the stmts-          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)--          -- (B) Do the LHSes-        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s--          --    ...bring them and their fixities into scope-        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)-              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)-              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)-              implicit_uses = mkNameSet $ concatMap snd $ rec_uses-        ; bindLocalNamesFV bound_names $-          addLocalFixities fix_env bound_names $ do--          -- (C) do the right-hand-sides and thing-inside-        { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv-        ; (res, fvs) <- cont segs-        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))-                rec_uses-        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)-        ; return (res, fvs) }}---- get all the fixity decls in any Let stmt-collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]-collectRecStmtsFixities l =-    foldr (\ s -> \acc -> case s of-            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->-              foldr (\ sig -> \ acc -> case sig of-                                         (L loc (FixSig _ s)) -> (L loc s) : acc-                                         _ -> acc) acc sigs-            _ -> acc) [] l---- left-hand sides--rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv-                -> LStmt GhcPs body-                   -- rename LHS, and return its FVs-                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,-                   -- so we don't bother to compute it accurately in the other cases-                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]--rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))-  = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]--rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))-  = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]--rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))-  = do-      -- should the ctxt be MDo instead?-      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat-      return [(L loc (BindStmt noExtField pat' body a b), fv_pat)]--rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))-  = failWith (badIpBinds (text "an mdo expression") binds)--rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))-    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds-         return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))),-                 -- Warning: this is bogus; see function invariant-                 emptyFVs-                 )]---- XXX Do we need to do something with the return and mfix names?-rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec-    = rn_rec_stmts_lhs fix_env stmts--rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo-  = pprPanic "rn_rec_stmt" (ppr stmt)--rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo-  = pprPanic "rn_rec_stmt" (ppr stmt)--rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet-  = pprPanic "rn_rec_stmt" (ppr stmt)--rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))-  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"-rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))))-  = noExtCon nec-rn_rec_stmt_lhs _ (L _ (XStmtLR nec))-  = noExtCon nec--rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv-                 -> [LStmt GhcPs body]-                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]-rn_rec_stmts_lhs fix_env stmts-  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts-       ; let boundNames = collectLStmtsBinders (map fst ls)-            -- First do error checking: we need to check for dups here because we-            -- don't bind all of the variables from the Stmt at once-            -- with bindLocatedLocals.-       ; checkDupNames boundNames-       ; return ls }----- right-hand-sides--rn_rec_stmt :: (Outputable (body GhcPs)) =>-               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-            -> [Name]-            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)-            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]-        -- Rename a Stmt that is inside a RecStmt (or mdo)-        -- Assumes all binders are already in scope-        -- Turns each stmt into a singleton Stmt-rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)-  = do  { (body', fv_expr) <- rnBody body-        ; (ret_op, fvs1)   <- lookupSyntaxName returnMName-        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,-                   L loc (LastStmt noExtField body' noret ret_op))] }--rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)-  = do { (body', fvs) <- rnBody body-       ; (then_op, fvs1) <- lookupSyntaxName thenMName-       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,-                 L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }--rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)-  = do { (body', fv_expr) <- rnBody body-       ; (bind_op, fvs1) <- lookupSyntaxName bindMName--       ; (fail_op, fvs2) <- getMonadFailOp--       ; let bndrs = mkNameSet (collectPatBinders pat')-             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2-       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,-                  L loc (BindStmt noExtField pat' body' bind_op fail_op))] }--rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)-  = failWith (badIpBinds (text "an mdo expression") binds)--rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)-  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'-           -- fixities and unused are handled above in rnRecStmtsAndThen-       ; let fvs = allUses du_binds-       ; return [(duDefs du_binds, fvs, emptyNameSet,-                 L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] }---- no RecStmt case because they get flattened above when doing the LHSes-rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)-  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)--rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo-  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)--rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo-  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)--rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _)-  = noExtCon nec--rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)-  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"--rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)-  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)--rn_rec_stmt _ _ (L _ (XStmtLR nec), _)-  = noExtCon nec--rn_rec_stmts :: Outputable (body GhcPs) =>-                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-             -> [Name]-             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]-             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]-rn_rec_stmts rnBody bndrs stmts-  = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts-       ; return (concat segs_s) }------------------------------------------------segmentRecStmts :: SrcSpan -> HsStmtContext Name-                -> Stmt GhcRn body-                -> [Segment (LStmt GhcRn body)] -> FreeVars-                -> ([LStmt GhcRn body], FreeVars)--segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later-  | null segs-  = ([], fvs_later)--  | MDoExpr <- ctxt-  = segsToStmts empty_rec_stmt grouped_segs fvs_later-               -- Step 4: Turn the segments into Stmts-                --         Use RecStmt when and only when there are fwd refs-                --         Also gather up the uses from the end towards the-                --         start, so we can tell the RecStmt which things are-                --         used 'after' the RecStmt--  | otherwise-  = ([ L loc $-       empty_rec_stmt { recS_stmts = ss-                      , recS_later_ids = nameSetElemsStable-                                           (defs `intersectNameSet` fvs_later)-                      , recS_rec_ids   = nameSetElemsStable-                                           (defs `intersectNameSet` uses) }]-          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-    , uses `plusFV` fvs_later)--  where-    (defs_s, uses_s, _, ss) = unzip4 segs-    defs = plusFVs defs_s-    uses = plusFVs uses_s--                -- Step 2: Fill in the fwd refs.-                --         The segments are all singletons, but their fwd-ref-                --         field mentions all the things used by the segment-                --         that are bound after their use-    segs_w_fwd_refs = addFwdRefs segs--                -- Step 3: Group together the segments to make bigger segments-                --         Invariant: in the result, no segment uses a variable-                --                    bound in a later segment-    grouped_segs = glomSegments ctxt segs_w_fwd_refs-------------------------------addFwdRefs :: [Segment a] -> [Segment a]--- So far the segments only have forward refs *within* the Stmt---      (which happens for bind:  x <- ...x...)--- This function adds the cross-seg fwd ref info--addFwdRefs segs-  = fst (foldr mk_seg ([], emptyNameSet) segs)-  where-    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)-        = (new_seg : segs, all_defs)-        where-          new_seg = (defs, uses, new_fwds, stmts)-          all_defs = later_defs `unionNameSet` defs-          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)-                -- Add the downstream fwd refs here--{--Note [Segmenting mdo]-~~~~~~~~~~~~~~~~~~~~~-NB. June 7 2012: We only glom segments that appear in an explicit mdo;-and leave those found in "do rec"'s intact.  See-https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion-leading to this design choice.  Hence the test in segmentRecStmts.--Note [Glomming segments]-~~~~~~~~~~~~~~~~~~~~~~~~-Glomming the singleton segments of an mdo into minimal recursive groups.--At first I thought this was just strongly connected components, but-there's an important constraint: the order of the stmts must not change.--Consider-     mdo { x <- ...y...-           p <- z-           y <- ...x...-           q <- x-           z <- y-           r <- x }--Here, the first stmt mention 'y', which is bound in the third.-But that means that the innocent second stmt (p <- z) gets caught-up in the recursion.  And that in turn means that the binding for-'z' has to be included... and so on.--Start at the tail { r <- x }-Now add the next one { z <- y ; r <- x }-Now add one more     { q <- x ; z <- y ; r <- x }-Now one more... but this time we have to group a bunch into rec-     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }-Now one more, which we can add on without a rec-     { p <- z ;-       rec { y <- ...x... ; q <- x ; z <- y } ;-       r <- x }-Finally we add the last one; since it mentions y we have to-glom it together with the first two groups-     { rec { x <- ...y...; p <- z ; y <- ...x... ;-             q <- x ; z <- y } ;-       r <- x }--}--glomSegments :: HsStmtContext Name-             -> [Segment (LStmt GhcRn body)]-             -> [Segment [LStmt GhcRn body]]-                                  -- Each segment has a non-empty list of Stmts--- See Note [Glomming segments]--glomSegments _ [] = []-glomSegments ctxt ((defs,uses,fwds,stmt) : segs)-        -- Actually stmts will always be a singleton-  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others-  where-    segs'            = glomSegments ctxt segs-    (extras, others) = grab uses segs'-    (ds, us, fs, ss) = unzip4 extras--    seg_defs  = plusFVs ds `plusFV` defs-    seg_uses  = plusFVs us `plusFV` uses-    seg_fwds  = plusFVs fs `plusFV` fwds-    seg_stmts = stmt : concat ss--    grab :: NameSet             -- The client-         -> [Segment a]-         -> ([Segment a],       -- Needed by the 'client'-             [Segment a])       -- Not needed by the client-        -- The result is simply a split of the input-    grab uses dus-        = (reverse yeses, reverse noes)-        where-          (noes, yeses)           = span not_needed (reverse dus)-          not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)-------------------------------------------------------segsToStmts :: Stmt GhcRn body-                                  -- A RecStmt with the SyntaxOps filled in-            -> [Segment [LStmt GhcRn body]]-                                  -- Each Segment has a non-empty list of Stmts-            -> FreeVars           -- Free vars used 'later'-            -> ([LStmt GhcRn body], FreeVars)--segsToStmts _ [] fvs_later = ([], fvs_later)-segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later-  = ASSERT( not (null ss) )-    (new_stmt : later_stmts, later_uses `plusFV` uses)-  where-    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later-    new_stmt | non_rec   = head ss-             | otherwise = L (getLoc (head ss)) rec_stmt-    rec_stmt = empty_rec_stmt { recS_stmts     = ss-                              , recS_later_ids = nameSetElemsStable used_later-                              , recS_rec_ids   = nameSetElemsStable fwds }-          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-    non_rec    = isSingleton ss && isEmptyNameSet fwds-    used_later = defs `intersectNameSet` later_uses-                                -- The ones needed after the RecStmt--{--************************************************************************-*                                                                      *-ApplicativeDo-*                                                                      *-************************************************************************--Note [ApplicativeDo]--= Example =--For a sequence of statements-- do-     x <- A-     y <- B x-     z <- C-     return (f x y z)--We want to transform this to--  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C--It would be easy to notice that "y <- B x" and "z <- C" are-independent and do something like this:-- do-     x <- A-     (y,z) <- (,) <$> B x <*> C-     return (f x y z)--But this isn't enough! A and C were also independent, and this-transformation loses the ability to do A and C in parallel.--The algorithm works by first splitting the sequence of statements into-independent "segments", and a separate "tail" (the final statement). In-our example above, the segements would be--     [ x <- A-     , y <- B x ]--     [ z <- C ]--and the tail is:--     return (f x y z)--Then we take these segments and make an Applicative expression from them:--     (\(x,y) z -> return (f x y z))-       <$> do { x <- A; y <- B x; return (x,y) }-       <*> C--Finally, we recursively apply the transformation to each segment, to-discover any nested parallelism.--= Syntax & spec =--  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...--  stmt ::= pat <- expr-         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1-         | ...                    -- other kinds of statement (e.g. let)--  arg ::= pat <- expr-        | {stmt_1; ..; stmt_n} {var_1..var_n}--(note that in the actual implementation,the expr in a do statement is-represented by a LastStmt as the final stmt, this is just a-representational issue and may change later.)--== Transformation to introduce applicative stmts ==--ado {} tail = tail-ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'-ado {one} tail = one : tail-ado stmts tail-  | n == 1 = ado before (ado after tail)-    where (before,after) = split(stmts_1)-  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail-  where-    {stmts_1 .. stmts_n} = segments(stmts)--segments(stmts) =-  -- divide stmts into segments with no interdependencies--mkArg({pat <- expr}) = (pat <- expr)-mkArg({stmt_1; ...; stmt_n}) =-  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}--split({stmt_1; ..; stmt_n) =-  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})-  -- 1 <= i <= n-  -- i is a good place to insert a bind--== Desugaring for do ==--dsDo {} expr = expr--dsDo {pat <- rhs; stmts} expr =-   rhs >>= \pat -> dsDo stmts expr--dsDo {(arg_1 | ... | arg_n)} (return expr) =-  (\argpat (arg_1) .. argpat(arg_n) -> expr)-     <$> argexpr(arg_1)-     <*> ...-     <*> argexpr(arg_n)--dsDo {(arg_1 | ... | arg_n); stmts} expr =-  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)-     <$> argexpr(arg_1)-     <*> ...-     <*> argexpr(arg_n)--= Relevant modules in the rest of the compiler =--ApplicativeDo touches a few phases in the compiler:--* Renamer: The journey begins here in the renamer, where do-blocks are-  scheduled as outlined above and transformed into applicative-  combinators.  However, the code is still represented as a do-block-  with special forms of applicative statements. This allows us to-  recover the original do-block when e.g.  printing type errors, where-  we don't want to show any of the applicative combinators since they-  don't exist in the source code.-  See ApplicativeStmt and ApplicativeArg in HsExpr.--* Typechecker: ApplicativeDo passes through the typechecker much like any-  other form of expression. The only crux is that the typechecker has to-  be aware of the special ApplicativeDo statements in the do-notation, and-  typecheck them appropriately.-  Relevant module: TcMatches--* Desugarer: Any do-block which contains applicative statements is desugared-  as outlined above, to use the Applicative combinators.-  Relevant module: DsExpr---}---- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and--- 'pureName' due to @RebindableSyntax@.-data MonadNames = MonadNames { return_name, pure_name :: Name }--instance Outputable MonadNames where-  ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =-    hcat-    [text "MonadNames { return_name = "-    ,ppr return_name-    ,text ", pure_name = "-    ,ppr pure_name-    ,text "}"-    ]---- | rearrange a list of statements using ApplicativeDoStmt.  See--- Note [ApplicativeDo].-rearrangeForApplicativeDo-  :: HsStmtContext Name-  -> [(ExprLStmt GhcRn, FreeVars)]-  -> RnM ([ExprLStmt GhcRn], FreeVars)--rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)-rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)-rearrangeForApplicativeDo ctxt stmts0 = do-  optimal_ado <- goptM Opt_OptimalApplicativeDo-  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts-                | otherwise = mkStmtTreeHeuristic stmts-  traceRn "rearrangeForADo" (ppr stmt_tree)-  return_name <- lookupSyntaxName' returnMName-  pure_name   <- lookupSyntaxName' pureAName-  let monad_names = MonadNames { return_name = return_name-                               , pure_name   = pure_name }-  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs-  where-    (stmts,(last,last_fvs)) = findLast stmts0-    findLast [] = error "findLast"-    findLast [last] = ([],last)-    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs---- | A tree of statements using a mixture of applicative and bind constructs.-data StmtTree a-  = StmtTreeOne a-  | StmtTreeBind (StmtTree a) (StmtTree a)-  | StmtTreeApplicative [StmtTree a]--instance Outputable a => Outputable (StmtTree a) where-  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)-  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")-                                            2 (sep [ppr x, ppr y]))-  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")-                                            2 (vcat (map ppr xs)))--flattenStmtTree :: StmtTree a -> [a]-flattenStmtTree t = go t []- where-  go (StmtTreeOne a) as = a : as-  go (StmtTreeBind l r) as = go l (go r as)-  go (StmtTreeApplicative ts) as = foldr go as ts--type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)-type Cost = Int---- | Turn a sequence of statements into an ExprStmtTree using a--- heuristic algorithm.  /O(n^2)/-mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree-mkStmtTreeHeuristic [one] = StmtTreeOne one-mkStmtTreeHeuristic stmts =-  case segments stmts of-    [one] -> split one-    segs -> StmtTreeApplicative (map split segs)- where-  split [one] = StmtTreeOne one-  split stmts =-    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)-    where (before, after) = splitSegment stmts---- | Turn a sequence of statements into an ExprStmtTree optimally,--- using dynamic programming.  /O(n^3)/-mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree-mkStmtTreeOptimal stmts =-  ASSERT(not (null stmts)) -- the empty case is handled by the caller;-                           -- we don't support empty StmtTrees.-  fst (arr ! (0,n))-  where-    n = length stmts - 1-    stmt_arr = listArray (0,n) stmts--    -- lazy cache of optimal trees for subsequences of the input-    arr :: Array (Int,Int) (ExprStmtTree, Cost)-    arr = array ((0,0),(n,n))-             [ ((lo,hi), tree lo hi)-             | lo <- [0..n]-             , hi <- [lo..n] ]--    -- compute the optimal tree for the sequence [lo..hi]-    tree lo hi-      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)-      | otherwise =-         case segments [ stmt_arr ! i | i <- [lo..hi] ] of-           [] -> panic "mkStmtTree"-           [_one] -> split lo hi-           segs -> (StmtTreeApplicative trees, maximum costs)-             where-               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs-               (trees,costs) = unzip (map (uncurry split) (tail bounds))--    -- find the best place to split the segment [lo..hi]-    split :: Int -> Int -> (ExprStmtTree, Cost)-    split lo hi-      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)-      | otherwise = (StmtTreeBind before after, c1+c2)-        where-         -- As per the paper, for a sequence s1...sn, we want to find-         -- the split with the minimum cost, where the cost is the-         -- sum of the cost of the left and right subsequences.-         ---         -- As an optimisation (also in the paper) if the cost of-         -- s1..s(n-1) is different from the cost of s2..sn, we know-         -- that the optimal solution is the lower of the two.  Only-         -- in the case that these two have the same cost do we need-         -- to do the exhaustive search.-         ---         ((before,c1),(after,c2))-           | hi - lo == 1-           = ((StmtTreeOne (stmt_arr ! lo), 1),-              (StmtTreeOne (stmt_arr ! hi), 1))-           | left_cost < right_cost-           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))-           | left_cost > right_cost-           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))-           | otherwise = minimumBy (comparing cost) alternatives-           where-             (left, left_cost) = arr ! (lo,hi-1)-             (right, right_cost) = arr ! (lo+1,hi)-             cost ((_,c1),(_,c2)) = c1 + c2-             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))-                            | k <- [lo .. hi-1] ]----- | Turn the ExprStmtTree back into a sequence of statements, using--- ApplicativeStmt where necessary.-stmtTreeToStmts-  :: MonadNames-  -> HsStmtContext Name-  -> ExprStmtTree-  -> [ExprLStmt GhcRn]             -- ^ the "tail"-  -> FreeVars                     -- ^ free variables of the tail-  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,-         , FreeVars )             -- , things we needed---- If we have a single bind, and we can do it without a join, transform--- to an ApplicativeStmt.  This corresponds to the rule---   dsBlock [pat <- rhs] (return expr) = expr <$> rhs--- In the spec, but we do it here rather than in the desugarer,--- because we need the typechecker to typecheck the <$> form rather than--- the bind form, which would give rise to a Monad constraint.-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _))-                tail _tail_fvs-  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail-  -- See Note [ApplicativeDo and strict patterns]-  = mkApplicativeStmt ctxt [ApplicativeArgOne-                            { xarg_app_arg_one = noExtField-                            , app_arg_pattern  = pat-                            , arg_expr         = rhs-                            , is_body_stmt     = False-                            , fail_operator    = fail_op}]-                      False tail'-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_))-                tail _tail_fvs-  | (False,tail') <- needJoin monad_names tail-  = mkApplicativeStmt ctxt-      [ApplicativeArgOne-       { xarg_app_arg_one = noExtField-       , app_arg_pattern  = nlWildPatName-       , arg_expr         = rhs-       , is_body_stmt     = True-       , fail_operator    = fail_op}] False tail'--stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =-  return (s : tail, emptyNameSet)--stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do-  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs-  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))-  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs-  return (stmts2, fvs1 `plusFV` fvs2)--stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do-   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees-   let (stmts', fvss) = unzip pairs-   let (need_join, tail') =-         if any hasStrictPattern trees-         then (True, tail)-         else needJoin monad_names tail--   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'-   return (stmts, unionNameSets (fvs:fvss))- where-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))-     = return (ApplicativeArgOne-               { xarg_app_arg_one = noExtField-               , app_arg_pattern  = pat-               , arg_expr         = exp-               , is_body_stmt     = False-               , fail_operator    = fail_op-               }, emptyFVs)-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =-     return (ApplicativeArgOne-             { xarg_app_arg_one = noExtField-             , app_arg_pattern  = nlWildPatName-             , arg_expr         = exp-             , is_body_stmt     = True-             , fail_operator    = fail_op-             }, emptyFVs)-   stmtTreeArg ctxt tail_fvs tree = do-     let stmts = flattenStmtTree tree-         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)-                     `intersectNameSet` tail_fvs-         pvars = nameSetElemsStable pvarset-           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]-         pat = mkBigLHsVarPatTup pvars-         tup = mkBigLHsVarTup pvars-     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset-     (mb_ret, fvs1) <--        if | L _ ApplicativeStmt{} <- last stmts' ->-             return (unLoc tup, emptyNameSet)-           | otherwise -> do-             ret <- lookupSyntaxName' returnMName-             let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup-             return (expr, emptyFVs)-     return ( ApplicativeArgMany-              { xarg_app_arg_many = noExtField-              , app_stmts         = stmts'-              , final_expr        = mb_ret-              , bv_pattern        = pat-              }-            , fvs1 `plusFV` fvs2)----- | Divide a sequence of statements into segments, where no segment--- depends on any variables defined by a statement in another segment.-segments-  :: [(ExprLStmt GhcRn, FreeVars)]-  -> [[(ExprLStmt GhcRn, FreeVars)]]-segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)-  where-    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)--    -- We would rather not have a segment that just has LetStmts in-    -- it, so combine those with an adjacent segment where possible.-    merge [] = []-    merge (seg : segs)-       = case rest of-          [] -> [(seg,all_lets)]-          ((s,s_lets):ss) | all_lets || s_lets-               -> (seg ++ s, all_lets && s_lets) : ss-          _otherwise -> (seg,all_lets) : rest-      where-        rest = merge segs-        all_lets = all (isLetStmt . fst) seg--    -- walk splits the statement sequence into segments, traversing-    -- the sequence from the back to the front, and keeping track of-    -- the set of free variables of the current segment.  Whenever-    -- this set of free variables is empty, we have a complete segment.-    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]-    walk [] = []-    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest-      where (seg,rest) = chunter fvs' stmts-            (_, fvs') = stmtRefs stmt fvs--    chunter _ [] = ([], [])-    chunter vars ((stmt,fvs) : rest)-       | not (isEmptyNameSet vars)-       || isStrictPatternBind stmt-           -- See Note [ApplicativeDo and strict patterns]-       = ((stmt,fvs) : chunk, rest')-       where (chunk,rest') = chunter vars' rest-             (pvars, evars) = stmtRefs stmt fvs-             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars-    chunter _ rest = ([], rest)--    stmtRefs stmt fvs-      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)-      | otherwise      = (pvars, fvs')-      where fvs' = fvs `intersectNameSet` allvars-            pvars = mkNameSet (collectStmtBinders (unLoc stmt))--    isStrictPatternBind :: ExprLStmt GhcRn -> Bool-    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat-    isStrictPatternBind _ = False--{--Note [ApplicativeDo and strict patterns]--A strict pattern match is really a dependency.  For example,--do-  (x,y) <- A-  z <- B-  return C--The pattern (_,_) must be matched strictly before we do B.  If we-allowed this to be transformed into--  (\(x,y) -> \z -> C) <$> A <*> B--then it could be lazier than the standard desuraging using >>=.  See #13875-for more examples.--Thus, whenever we have a strict pattern match, we treat it as a-dependency between that statement and the following one.  The-dependency prevents those two statements from being performed "in-parallel" in an ApplicativeStmt, but doesn't otherwise affect what we-can do with the rest of the statements in the same "do" expression.--}--isStrictPattern :: LPat (GhcPass p) -> Bool-isStrictPattern lpat =-  case unLoc lpat of-    WildPat{}       -> False-    VarPat{}        -> False-    LazyPat{}       -> False-    AsPat _ _ p     -> isStrictPattern p-    ParPat _ p      -> isStrictPattern p-    ViewPat _ _ p   -> isStrictPattern p-    SigPat _ p _    -> isStrictPattern p-    BangPat{}       -> True-    ListPat{}       -> True-    TuplePat{}      -> True-    SumPat{}        -> True-    ConPatIn{}      -> True-    ConPatOut{}     -> True-    LitPat{}        -> True-    NPat{}          -> True-    NPlusKPat{}     -> True-    SplicePat{}     -> True-    _otherwise -> panic "isStrictPattern"--hasStrictPattern :: ExprStmtTree -> Bool-hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat-hasStrictPattern (StmtTreeOne _) = False-hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b-hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees---isLetStmt :: LStmt a b -> Bool-isLetStmt (L _ LetStmt{}) = True-isLetStmt _ = False---- | Find a "good" place to insert a bind in an indivisible segment.--- This is the only place where we use heuristics.  The current--- heuristic is to peel off the first group of independent statements--- and put the bind after those.-splitSegment-  :: [(ExprLStmt GhcRn, FreeVars)]-  -> ( [(ExprLStmt GhcRn, FreeVars)]-     , [(ExprLStmt GhcRn, FreeVars)] )-splitSegment [one,two] = ([one],[two])-  -- there is no choice when there are only two statements; this just saves-  -- some work in a common case.-splitSegment stmts-  | Just (lets,binds,rest) <- slurpIndependentStmts stmts-  =  if not (null lets)-       then (lets, binds++rest)-       else (lets++binds, rest)-  | otherwise-  = case stmts of-      (x:xs) -> ([x],xs)-      _other -> (stmts,[])--slurpIndependentStmts-   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]-   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts-            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts-            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )-slurpIndependentStmts stmts = go [] [] emptyNameSet stmts- where-  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt-  -- in this group, then add it to the group. We have to be careful about-  -- strict patterns though; splitSegments expects that if we return Just-  -- then we have actually done some splitting. Otherwise it will go into-  -- an infinite loop (#14163).-  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)-    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)-    = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep)-         bndrs' rest-    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)-  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this-  -- group, then move it to the beginning, so that it doesn't interfere with-  -- grouping more BindStmts.-  -- TODO: perhaps we shouldn't do this if there are any strict bindings,-  -- because we might be moving evaluation earlier.-  go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)-    | isEmptyNameSet (bndrs `intersectNameSet` fvs)-    = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest-  go _ []  _ _ = Nothing-  go _ [_] _ _ = Nothing-  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)---- | Build an ApplicativeStmt, and strip the "return" from the tail--- if necessary.------ For example, if we start with---   do x <- E1; y <- E2; return (f x y)--- then we get---   do (E1[x] | E2[y]); f x y------ the LastStmt in this case has the return removed, but we set the--- flag on the LastStmt to indicate this, so that we can print out the--- original statement correctly in error messages.  It is easier to do--- it this way rather than try to ignore the return later in both the--- typechecker and the desugarer (I tried it that way first!).-mkApplicativeStmt-  :: HsStmtContext Name-  -> [ApplicativeArg GhcRn]             -- ^ The args-  -> Bool                               -- ^ True <=> need a join-  -> [ExprLStmt GhcRn]        -- ^ The body statements-  -> RnM ([ExprLStmt GhcRn], FreeVars)-mkApplicativeStmt ctxt args need_join body_stmts-  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName-       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName-       ; (mb_join, fvs3) <--           if need_join then-             do { (join_op, fvs) <- lookupStmtName ctxt joinMName-                ; return (Just join_op, fvs) }-           else-             return (Nothing, emptyNameSet)-       ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField-               (zip (fmap_op : repeat ap_op) args)-               mb_join-       ; return ( applicative_stmt : body_stmts-                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }---- | Given the statements following an ApplicativeStmt, determine whether--- we need a @join@ or not, and remove the @return@ if necessary.-needJoin :: MonadNames-         -> [ExprLStmt GhcRn]-         -> (Bool, [ExprLStmt GhcRn])-needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg-needJoin monad_names  [L loc (LastStmt _ e _ t)]- | Just arg <- isReturnApp monad_names e =-       (False, [L loc (LastStmt noExtField arg True t)])-needJoin _monad_names stmts = (True, stmts)---- | @Just e@, if the expression is @return e@ or @return $ e@,--- otherwise @Nothing@-isReturnApp :: MonadNames-            -> LHsExpr GhcRn-            -> Maybe (LHsExpr GhcRn)-isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr-isReturnApp monad_names (L _ e) = case e of-  OpApp _ l op r | is_return l, is_dollar op -> Just r-  HsApp _ f arg  | is_return f               -> Just arg-  _otherwise -> Nothing- where-  is_var f (L _ (HsPar _ e)) = is_var f e-  is_var f (L _ (HsAppType _ e _)) = is_var f e-  is_var f (L _ (HsVar _ (L _ r))) = f r-       -- TODO: I don't know how to get this right for rebindable syntax-  is_var _ _ = False--  is_return = is_var (\n -> n == return_name monad_names-                         || n == pure_name monad_names)-  is_dollar = is_var (`hasKey` dollarIdKey)--{--************************************************************************-*                                                                      *-\subsubsection{Errors}-*                                                                      *-************************************************************************--}--checkEmptyStmts :: HsStmtContext Name -> RnM ()--- We've seen an empty sequence of Stmts... is that ok?-checkEmptyStmts ctxt-  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))--okEmpty :: HsStmtContext a -> Bool-okEmpty (PatGuard {}) = True-okEmpty _             = False--emptyErr :: HsStmtContext Name -> SDoc-emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"-emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"-emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt-------------------------checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name-              -> LStmt GhcPs (Located (body GhcPs))-              -> RnM (LStmt GhcPs (Located (body GhcPs)))-checkLastStmt ctxt lstmt@(L loc stmt)-  = case ctxt of-      ListComp  -> check_comp-      MonadComp -> check_comp-      ArrowExpr -> check_do-      DoExpr    -> check_do-      MDoExpr   -> check_do-      _         -> check_other-  where-    check_do    -- Expect BodyStmt, and change it to LastStmt-      = case stmt of-          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))-          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a-                                             -- LastStmt directly (unlike the parser)-          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }-    last_error = (text "The last statement in" <+> pprAStmtContext ctxt-                  <+> text "must be an expression")--    check_comp  -- Expect LastStmt; this should be enforced by the parser!-      = case stmt of-          LastStmt {} -> return lstmt-          _           -> pprPanic "checkLastStmt" (ppr lstmt)--    check_other -- Behave just as if this wasn't the last stmt-      = do { checkStmt ctxt lstmt; return lstmt }---- Checking when a particular Stmt is ok-checkStmt :: HsStmtContext Name-          -> LStmt GhcPs (Located (body GhcPs))-          -> RnM ()-checkStmt ctxt (L _ stmt)-  = do { dflags <- getDynFlags-       ; case okStmt dflags ctxt stmt of-           IsValid        -> return ()-           NotValid extra -> addErr (msg $$ extra) }-  where-   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")-             , text "in" <+> pprAStmtContext ctxt ]--pprStmtCat :: Stmt (GhcPass a) body -> SDoc-pprStmtCat (TransStmt {})     = text "transform"-pprStmtCat (LastStmt {})      = text "return expression"-pprStmtCat (BodyStmt {})      = text "body"-pprStmtCat (BindStmt {})      = text "binding"-pprStmtCat (LetStmt {})       = text "let"-pprStmtCat (RecStmt {})       = text "rec"-pprStmtCat (ParStmt {})       = text "parallel"-pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"-pprStmtCat (XStmtLR nec)        = noExtCon nec---------------emptyInvalid :: Validity  -- Payload is the empty document-emptyInvalid = NotValid Outputable.empty--okStmt, okDoStmt, okCompStmt, okParStmt-   :: DynFlags -> HsStmtContext Name-   -> Stmt GhcPs (Located (body GhcPs)) -> Validity--- Return Nothing if OK, (Just extra) if not ok--- The "extra" is an SDoc that is appended to a generic error message--okStmt dflags ctxt stmt-  = case ctxt of-      PatGuard {}        -> okPatGuardStmt stmt-      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt-      DoExpr             -> okDoStmt   dflags ctxt stmt-      MDoExpr            -> okDoStmt   dflags ctxt stmt-      ArrowExpr          -> okDoStmt   dflags ctxt stmt-      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt-      ListComp           -> okCompStmt dflags ctxt stmt-      MonadComp          -> okCompStmt dflags ctxt stmt-      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt----------------okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity-okPatGuardStmt stmt-  = case stmt of-      BodyStmt {} -> IsValid-      BindStmt {} -> IsValid-      LetStmt {}  -> IsValid-      _           -> emptyInvalid----------------okParStmt dflags ctxt stmt-  = case stmt of-      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid-      _                              -> okStmt dflags ctxt stmt-------------------okDoStmt dflags ctxt stmt-  = case stmt of-       RecStmt {}-         | LangExt.RecursiveDo `xopt` dflags -> IsValid-         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'-         | otherwise         -> NotValid (text "Use RecursiveDo")-       BindStmt {} -> IsValid-       LetStmt {}  -> IsValid-       BodyStmt {} -> IsValid-       _           -> emptyInvalid-------------------okCompStmt dflags _ stmt-  = case stmt of-       BindStmt {} -> IsValid-       LetStmt {}  -> IsValid-       BodyStmt {} -> IsValid-       ParStmt {}-         | LangExt.ParallelListComp `xopt` dflags -> IsValid-         | otherwise -> NotValid (text "Use ParallelListComp")-       TransStmt {}-         | LangExt.TransformListComp `xopt` dflags -> IsValid-         | otherwise -> NotValid (text "Use TransformListComp")-       RecStmt {}  -> emptyInvalid-       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)-       ApplicativeStmt {} -> emptyInvalid-       XStmtLR nec -> noExtCon nec------------checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()-checkTupleSection args-  = do  { tuple_section <- xoptM LangExt.TupleSections-        ; checkErr (all tupArgPresent args || tuple_section) msg }-  where-    msg = text "Illegal tuple section: use TupleSections"------------sectionErr :: HsExpr GhcPs -> SDoc-sectionErr expr-  = hang (text "A section must be enclosed in parentheses")-       2 (text "thus:" <+> (parens (ppr expr)))--badIpBinds :: Outputable a => SDoc -> a -> SDoc-badIpBinds what binds-  = hang (text "Implicit-parameter bindings illegal in" <+> what)-         2 (ppr binds)-------------monadFailOp :: LPat GhcPs-            -> HsStmtContext Name-            -> RnM (SyntaxExpr GhcRn, FreeVars)-monadFailOp pat ctxt-  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)-  -- we should not need to fail.-  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)--  -- For non-monadic contexts (e.g. guard patterns, list-  -- comprehensions, etc.) we should not need to fail.  See Note-  -- [Failing pattern matches in Stmts]-  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)--  | otherwise = getMonadFailOp--{--Note [Monad fail : Rebindable syntax, overloaded strings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Given the code-  foo x = do { Just y <- x; return y }--we expect it to desugar as-  foo x = x >>= \r -> case r of-                        Just y  -> return y-                        Nothing -> fail "Pattern match error"--But with RebindableSyntax and OverloadedStrings, we really want-it to desugar thus:-  foo x = x >>= \r -> case r of-                        Just y  -> return y-                        Nothing -> fail (fromString "Patterm match error")--So, in this case, we synthesize the function-  \x -> fail (fromString x)--(rather than plain 'fail') for the 'fail' operation. This is done in-'getMonadFailOp'.--}-getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op-getMonadFailOp- = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags-      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags-      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings-      }-  where-    reallyGetMonadFailOp rebindableSyntax overloadedStrings-      | rebindableSyntax && overloadedStrings = do-        (failExpr, failFvs) <- lookupSyntaxName failMName-        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName-        let arg_lit = fsLit "arg"-            arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit-            arg_syn_expr = mkRnSyntaxExpr arg_name-        let body :: LHsExpr GhcRn =-              nlHsApp (noLoc $ syn_expr failExpr)-                      (nlHsApp (noLoc $ syn_expr fromStringExpr)-                                (noLoc $ syn_expr arg_syn_expr))-        let failAfterFromStringExpr :: HsExpr GhcRn =-              unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body-        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =-              mkSyntaxExpr failAfterFromStringExpr-        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)-      | otherwise = lookupSyntaxName failMName
− compiler/rename/RnExpr.hs-boot 
@@ -1,17 +0,0 @@-module RnExpr where-import Name-import GHC.Hs-import NameSet     ( FreeVars )-import TcRnTypes-import SrcLoc      ( Located )-import Outputable  ( Outputable )--rnLExpr :: LHsExpr GhcPs-        -> RnM (LHsExpr GhcRn, FreeVars)--rnStmts :: --forall thing body.-           Outputable (body GhcPs) => HsStmtContext Name-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> [LStmt GhcPs (Located (body GhcPs))]-        -> ([Name] -> RnM (thing, FreeVars))-        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
− compiler/rename/RnFixity.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--{---This module contains code which maintains and manipulates the-fixity environment during renaming.---}-module RnFixity ( MiniFixityEnv,-                  addLocalFixities,-  lookupFixityRn, lookupFixityRn_help,-  lookupFieldFixityRn, lookupTyFixityRn ) where--import GhcPrelude--import LoadIface-import GHC.Hs-import RdrName-import HscTypes-import TcRnMonad-import Name-import NameEnv-import Module-import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,-                          defaultFixity, SourceText(..) )-import SrcLoc-import Outputable-import Maybes-import Data.List-import Data.Function    ( on )-import RnUnbound--{--*********************************************************-*                                                      *-                Fixities-*                                                      *-*********************************************************--Note [Fixity signature lookup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A fixity declaration like--    infixr 2 ?--can refer to a value-level operator, e.g.:--    (?) :: String -> String -> String--or a type-level operator, like:--    data (?) a b = A a | B b--so we extend the lookup of the reader name '?' to the TcClsName namespace, as-well as the original namespace.--The extended lookup is also used in other places, like resolution of-deprecation declarations, and lookup of names in GHCi.--}-----------------------------------type MiniFixityEnv = FastStringEnv (Located Fixity)-        -- Mini fixity env for the names we're about-        -- to bind, in a single binding group-        ---        -- It is keyed by the *FastString*, not the *OccName*, because-        -- the single fixity decl       infix 3 T-        -- affects both the data constructor T and the type constrctor T-        ---        -- We keep the location so that if we find-        -- a duplicate, we can report it sensibly------------------------------------- Used for nested fixity decls to bind names along with their fixities.--- the fixities are given as a UFM from an OccName's FastString to a fixity decl--addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a-addLocalFixities mini_fix_env names thing_inside-  = extendFixityEnv (mapMaybe find_fixity names) thing_inside-  where-    find_fixity name-      = case lookupFsEnv mini_fix_env (occNameFS occ) of-          Just lfix -> Just (name, FixItem occ (unLoc lfix))-          Nothing   -> Nothing-      where-        occ = nameOccName name--{-----------------------------------lookupFixity is a bit strange.--* Nested local fixity decls are put in the local fixity env, which we-  find with getFixtyEnv--* Imported fixities are found in the PIT--* Top-level fixity decls in this module may be for Names that are-    either  Global         (constructors, class operations)-    or      Local/Exported (everything else)-  (See notes with RnNames.getLocalDeclBinders for why we have this split.)-  We put them all in the local fixity environment--}--lookupFixityRn :: Name -> RnM Fixity-lookupFixityRn name = lookupFixityRn' name (nameOccName name)--lookupFixityRn' :: Name -> OccName -> RnM Fixity-lookupFixityRn' name = fmap snd . lookupFixityRn_help' name---- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'--- in a local environment or from an interface file. Otherwise, it returns--- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without--- user-supplied fixity declarations).-lookupFixityRn_help :: Name-                    -> RnM (Bool, Fixity)-lookupFixityRn_help name =-    lookupFixityRn_help' name (nameOccName name)--lookupFixityRn_help' :: Name-                     -> OccName-                     -> RnM (Bool, Fixity)-lookupFixityRn_help' name occ-  | isUnboundName name-  = return (False, Fixity NoSourceText minPrecedence InfixL)-    -- Minimise errors from ubound names; eg-    --    a>0 `foo` b>0-    -- where 'foo' is not in scope, should not give an error (#7937)--  | otherwise-  = do { local_fix_env <- getFixityEnv-       ; case lookupNameEnv local_fix_env name of {-           Just (FixItem _ fix) -> return (True, fix) ;-           Nothing ->--    do { this_mod <- getModule-       ; if nameIsLocalOrFrom this_mod name-               -- Local (and interactive) names are all in the-               -- fixity env, and don't have entries in the HPT-         then return (False, defaultFixity)-         else lookup_imported } } }-  where-    lookup_imported-      -- For imported names, we have to get their fixities by doing a-      -- loadInterfaceForName, and consulting the Ifaces that comes back-      -- from that, because the interface file for the Name might not-      -- have been loaded yet.  Why not?  Suppose you import module A,-      -- which exports a function 'f', thus;-      --        module CurrentModule where-      --          import A( f )-      --        module A( f ) where-      --          import B( f )-      -- Then B isn't loaded right away (after all, it's possible that-      -- nothing from B will be used).  When we come across a use of-      -- 'f', we need to know its fixity, and it's then, and only-      -- then, that we load B.hi.  That is what's happening here.-      ---      -- loadInterfaceForName will find B.hi even if B is a hidden module,-      -- and that's what we want.-      = do { iface <- loadInterfaceForName doc name-           ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ-           ; let msg = case mb_fix of-                            Nothing ->-                                  text "looking up name" <+> ppr name-                              <+> text "in iface, but found no fixity for it."-                              <+> text "Using default fixity instead."-                            Just f ->-                                  text "looking up name in iface and found:"-                              <+> vcat [ppr name, ppr f]-           ; traceRn "lookupFixityRn_either:" msg-           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }--    doc = text "Checking fixity for" <+> ppr name------------------lookupTyFixityRn :: Located Name -> RnM Fixity-lookupTyFixityRn = lookupFixityRn . unLoc---- | Look up the fixity of a (possibly ambiguous) occurrence of a record field--- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as--- the field label, which might be different to the 'OccName' of the selector--- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are--- multiple possible selectors with different fixities, generate an error.-lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity-lookupFieldFixityRn (Unambiguous n lrdr)-  = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))-lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)-  where-    get_ambiguous_fixity :: RdrName -> RnM Fixity-    get_ambiguous_fixity rdr_name = do-      traceRn "get_ambiguous_fixity" (ppr rdr_name)-      rdr_env <- getGlobalRdrEnv-      let elts =  lookupGRE_RdrName rdr_name rdr_env--      fixities <- groupBy ((==) `on` snd) . zip elts-                  <$> mapM lookup_gre_fixity elts--      case fixities of-        -- There should always be at least one fixity.-        -- Something's very wrong if there are no fixity candidates, so panic-        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"-        [ (_, fix):_ ] -> return fix-        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)-                  >> return (Fixity NoSourceText minPrecedence InfixL)--    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)--    ambiguous_fixity_err rn ambigs-      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)-             , hang (text "Conflicts: ") 2 . vcat .-               map format_ambig $ concat ambigs ]--    format_ambig (elt, fix) = hang (ppr fix)-                                 2 (pprNameProvenance elt)-lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec
− compiler/rename/RnHsDoc.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where--import GhcPrelude--import TcRnTypes-import GHC.Hs-import SrcLoc---rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)-rnMbLHsDoc mb_doc = case mb_doc of-  Just doc -> do-    doc' <- rnLHsDoc doc-    return (Just doc')-  Nothing -> return Nothing--rnLHsDoc :: LHsDocString -> RnM LHsDocString-rnLHsDoc (L pos doc) = do-  doc' <- rnHsDoc doc-  return (L pos doc')--rnHsDoc :: HsDocString -> RnM HsDocString-rnHsDoc = pure
− compiler/rename/RnNames.hs 
@@ -1,1783 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[RnNames]{Extracting imported and top-level names in scope}--}--{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--module RnNames (-        rnImports, getLocalNonValBinders, newRecordSelector,-        extendGlobalRdrEnvRn,-        gresFromAvails,-        calculateAvails,-        reportUnusedNames,-        checkConName,-        mkChildEnv,-        findChildren,-        dodgyMsg,-        dodgyMsgInsert,-        findImportUsage,-        getMinimalImports,-        printMinimalImports,-        ImportDeclUsage-    ) where--#include "HsVersions.h"--import GhcPrelude--import DynFlags-import TyCoPpr-import GHC.Hs-import TcEnv-import RnEnv-import RnFixity-import RnUtils          ( warnUnusedTopBinds, mkFieldEnv )-import LoadIface        ( loadSrcInterface )-import TcRnMonad-import PrelNames-import Module-import Name-import NameEnv-import NameSet-import Avail-import FieldLabel-import HscTypes-import RdrName-import RdrHsSyn        ( setRdrNameSpace )-import Outputable-import Maybes-import SrcLoc-import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )-import Util-import FastString-import FastStringEnv-import Id-import Type-import PatSyn-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.Either      ( partitionEithers, isRight, rights )-import Data.Map         ( Map )-import qualified Data.Map as Map-import Data.Ord         ( comparing )-import Data.List        ( partition, (\\), find, sortBy )-import qualified Data.Set as S-import System.FilePath  ((</>))--import System.IO--{--************************************************************************-*                                                                      *-\subsection{rnImports}-*                                                                      *-************************************************************************--Note [Tracking Trust Transitively]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we import a package as well as checking that the direct imports are safe-according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]-we must also check that these rules hold transitively for all dependent modules-and packages. Doing this without caching any trust information would be very-slow as we would need to touch all packages and interface files a module depends-on. To avoid this we make use of the property that if a modules Safe Haskell-mode changes, this triggers a recompilation from that module in the dependcy-graph. So we can just worry mostly about direct imports.--There is one trust property that can change for a package though without-recompilation being triggered: package trust. So we must check that all-packages a module tranitively depends on to be trusted are still trusted when-we are compiling this module (as due to recompilation avoidance some modules-below may not be considered trusted any more without recompilation being-triggered).--We handle this by augmenting the existing transitive list of packages a module M-depends on with a bool for each package that says if it must be trusted when the-module M is being checked for trust. This list of trust required packages for a-single import is gathered in the rnImportDecl function and stored in an-ImportAvails data structure. The union of these trust required packages for all-imports is done by the rnImports function using the combine function which calls-the plusImportAvails function that is a union operation for the ImportAvails-type. This gives us in an ImportAvails structure all packages required to be-trusted for the module we are currently compiling. Checking that these packages-are still trusted (and that direct imports are trusted) is done in-HscMain.checkSafeImports.--See the note below, [Trust Own Package] for a corner case in this method and-how its handled.---Note [Trust Own Package]-~~~~~~~~~~~~~~~~~~~~~~~~-There is a corner case of package trust checking that the usual transitive check-doesn't cover. (For how the usual check operates see the Note [Tracking Trust-Transitively] below). The case is when you import a -XSafe module M and M-imports a -XTrustworthy module N. If N resides in a different package than M,-then the usual check works as M will record a package dependency on N's package-and mark it as required to be trusted. If N resides in the same package as M-though, then importing M should require its own package be trusted due to N-(since M is -XSafe so doesn't create this requirement by itself). The usual-check fails as a module doesn't record a package dependency of its own package.-So instead we now have a bool field in a modules interface file that simply-states if the module requires its own package to be trusted. This field avoids-us having to load all interface files that the module depends on to see if one-is trustworthy.---Note [Trust Transitive Property]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-So there is an interesting design question in regards to transitive trust-checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch-of modules and packages, some packages it requires to be trusted as its using--XTrustworthy modules from them. Now if I have a module A that doesn't use safe-haskell at all and simply imports B, should A inherit all the trust-requirements from B? Should A now also require that a package p is trusted since-B required it?--We currently say no but saying yes also makes sense. The difference is, if a-module M that doesn't use Safe Haskell imports a module N that does, should all-the trusted package requirements be dropped since M didn't declare that it cares-about Safe Haskell (so -XSafe is more strongly associated with the module doing-the importing) or should it be done still since the author of the module N that-uses Safe Haskell said they cared (so -XSafe is more strongly associated with-the module that was compiled that used it).--Going with yes is a simpler semantics we think and harder for the user to stuff-up but it does mean that Safe Haskell will affect users who don't care about-Safe Haskell as they might grab a package from Cabal which uses safe haskell (say-network) and that packages imports -XTrustworthy modules from another package-(say bytestring), so requires that package is trusted. The user may now get-compilation errors in code that doesn't do anything with Safe Haskell simply-because they are using the network package. They will have to call 'ghc-pkg-trust network' to get everything working. Due to this invasive nature of going-with yes we have gone with no for now.--}---- | Process Import Decls.  See 'rnImportDecl' for a description of what--- the return types represent.--- Note: Do the non SOURCE ones first, so that we get a helpful warning--- for SOURCE ones that are unnecessary-rnImports :: [LImportDecl GhcPs]-          -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)-rnImports imports = do-    tcg_env <- getGblEnv-    -- NB: want an identity module here, because it's OK for a signature-    -- module to import from its implementor-    let this_mod = tcg_mod tcg_env-    let (source, ordinary) = partition is_source_import imports-        is_source_import d = ideclSource (unLoc d)-    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary-    stuff2 <- mapAndReportM (rnImportDecl this_mod) source-    -- Safe Haskell: See Note [Tracking Trust Transitively]-    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)-    return (decls, rdr_env, imp_avails, hpc_usage)--  where-    -- See Note [Combining ImportAvails]-    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]-            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)-    combine ss =-      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr-            plus-            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)-            ss-      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },-            hpc_usage)--    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)-         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)-      = ( decl:decls,-          gbl_env1 `plusGlobalRdrEnv` gbl_env2,-          imp_avails1' `plusImportAvails` imp_avails2,-          hpc_usage1 || hpc_usage2,-          extendModuleSetList finsts_set new_finsts )-      where-      imp_avails1' = imp_avails1 { imp_finsts = [] }-      new_finsts = imp_finsts imp_avails1--{--Note [Combining ImportAvails]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-imp_finsts in ImportAvails is a list of family instance modules-transitively depended on by an import. imp_finsts for a currently-compiled module is a union of all the imp_finsts of imports.-Computing the union of two lists of size N is O(N^2) and if we-do it to M imports we end up with O(M*N^2). That can get very-expensive for bigger module hierarchies.--Union can be optimized to O(N log N) if we use a Set.-imp_finsts is converted back and forth between dep_finsts, so-changing a type of imp_finsts means either paying for the conversions-or changing the type of dep_finsts as well.--I've measured that the conversions would cost 20% of allocations on my-test case, so that can be ruled out.--Changing the type of dep_finsts forces checkFamInsts to-get the module lists in non-deterministic order. If we wanted to restore-the deterministic order, we'd have to sort there, which is an additional-cost. As far as I can tell, using a non-deterministic order is fine there,-but that's a brittle nonlocal property which I'd like to avoid.--Additionally, dep_finsts is read from an interface file, so its "natural"-type is a list. Which makes it a natural type for imp_finsts.--Since rnImports.combine is really the only place that would benefit from-it being a Set, it makes sense to optimize the hot loop in rnImports.combine-without changing the representation.--So here's what we do: instead of naively merging ImportAvails with-plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts-and compute the union on the side using Sets. When we're done, we can-convert it back to a list. One nice side effect of this approach is that-if there's a lot of overlap in the imp_finsts of imports, the-Set doesn't really need to grow and we don't need to allocate.--Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in-23s before, and 11s after.--}------ | Given a located import declaration @decl@ from @this_mod@,--- calculate the following pieces of information:------  1. An updated 'LImportDecl', where all unresolved 'RdrName' in---     the entity lists have been resolved into 'Name's,------  2. A 'GlobalRdrEnv' representing the new identifiers that were---     brought into scope (taking into account module qualification---     and hiding),------  3. 'ImportAvails' summarizing the identifiers that were imported---     by this declaration, and------  4. A boolean 'AnyHpcUsage' which is true if the imported module---     used HPC.-rnImportDecl  :: Module -> LImportDecl GhcPs-             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)-rnImportDecl this_mod-             (L loc decl@(ImportDecl { ideclExt = noExtField-                                     , ideclName = loc_imp_mod_name-                                     , ideclPkgQual = mb_pkg-                                     , ideclSource = want_boot, ideclSafe = mod_safe-                                     , ideclQualified = qual_style, ideclImplicit = implicit-                                     , ideclAs = as_mod, ideclHiding = imp_details }))-  = setSrcSpan loc $ do--    when (isJust mb_pkg) $ do-        pkg_imports <- xoptM LangExt.PackageImports-        when (not pkg_imports) $ addErr packageImportErr--    let qual_only = isImportDeclQualified qual_style--    -- If there's an error in loadInterface, (e.g. interface-    -- file not found) we get lots of spurious errors from 'filterImports'-    let imp_mod_name = unLoc loc_imp_mod_name-        doc = ppr imp_mod_name <+> text "is directly imported"--    -- Check for self-import, which confuses the typechecker (#9032)-    -- ghc --make rejects self-import cycles already, but batch-mode may not-    -- at least not until TcIface.tcHiBootIface, which is too late to avoid-    -- typechecker crashes.  (Indirect self imports are not caught until-    -- TcIface, see #10337 tracking how to make this error better.)-    ---    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this-    -- caused bug #10182: in one-shot mode, we should never load an hs-boot-    -- file for the module we are compiling into the EPS.  In principle,-    -- it should be possible to support this mode of use, but we would have to-    -- extend Provenance to support a local definition in a qualified location.-    -- For now, we don't support it, but see #10336-    when (imp_mod_name == moduleName this_mod &&-          (case mb_pkg of  -- If we have import "<pkg>" M, then we should-                           -- check that "<pkg>" is "this" (which is magic)-                           -- or the name of this_mod's package.  Yurgh!-                           -- c.f. GHC.findModule, and #9997-             Nothing         -> True-             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||-                            fsToUnitId pkg_fs == moduleUnitId this_mod))-         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))--    -- Check for a missing import list (Opt_WarnMissingImportList also-    -- checks for T(..) items but that is done in checkDodgyImport below)-    case imp_details of-        Just (False, _) -> return () -- Explicit import list-        _  | implicit   -> return () -- Do not bleat for implicit imports-           | qual_only  -> return ()-           | otherwise  -> whenWOptM Opt_WarnMissingImportList $-                           addWarn (Reason Opt_WarnMissingImportList)-                                   (missingImportListWarn imp_mod_name)--    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)--    -- Compiler sanity check: if the import didn't say-    -- {-# SOURCE #-} we should not get a hi-boot file-    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do--    -- Issue a user warning for a redundant {- SOURCE -} import-    -- NB that we arrange to read all the ordinary imports before-    -- any of the {- SOURCE -} imports.-    ---    -- in --make and GHCi, the compilation manager checks for this,-    -- and indeed we shouldn't do it here because the existence of-    -- the non-boot module depends on the compilation order, which-    -- is not deterministic.  The hs-boot test can show this up.-    dflags <- getDynFlags-    warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))-           (warnRedundantSourceImport imp_mod_name)-    when (mod_safe && not (safeImportsOn dflags)) $-        addErr (text "safe import can't be used as Safe Haskell isn't on!"-                $+$ ptext (sLit $ "please enable Safe Haskell through either "-                                   ++ "Safe, Trustworthy or Unsafe"))--    let-        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name-        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,-                                  is_dloc = loc, is_as = qual_mod_name }--    -- filter the imports according to the import declaration-    (new_imp_details, gres) <- filterImports iface imp_spec imp_details--    -- for certain error messages, we’d like to know what could be imported-    -- here, if everything were imported-    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing--    let gbl_env = mkGlobalRdrEnv gres--        is_hiding | Just (True,_) <- imp_details = True-                  | otherwise                    = False--        -- should the import be safe?-        mod_safe' = mod_safe-                    || (not implicit && safeDirectImpsReq dflags)-                    || (implicit && safeImplicitImpsReq dflags)--    let imv = ImportedModsVal-            { imv_name        = qual_mod_name-            , imv_span        = loc-            , imv_is_safe     = mod_safe'-            , imv_is_hiding   = is_hiding-            , imv_all_exports = potential_gres-            , imv_qualified   = qual_only-            }-        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)--    -- Complain if we import a deprecated module-    whenWOptM Opt_WarnWarningsDeprecations (-       case (mi_warns iface) of-          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)-                                (moduleWarn imp_mod_name txt)-          _           -> return ()-     )--    let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'-                                   , ideclHiding = new_imp_details })--    return (new_imp_decl, gbl_env, imports, mi_hpc iface)-rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec---- | Calculate the 'ImportAvails' induced by an import of a particular--- interface, but without 'imp_mods'.-calculateAvails :: DynFlags-                -> ModIface-                -> IsSafeImport-                -> IsBootInterface-                -> ImportedBy-                -> ImportAvails-calculateAvails dflags iface mod_safe' want_boot imported_by =-  let imp_mod    = mi_module iface-      imp_sem_mod= mi_semantic_module iface-      orph_iface = mi_orphan (mi_final_exts iface)-      has_finsts = mi_finsts (mi_final_exts iface)-      deps       = mi_deps iface-      trust      = getSafeMode $ mi_trust iface-      trust_pkg  = mi_trust_pkg iface--      -- If the module exports anything defined in this module, just-      -- ignore it.  Reason: otherwise it looks as if there are two-      -- local definition sites for the thing, and an error gets-      -- reported.  Easiest thing is just to filter them out up-      -- front. This situation only arises if a module imports-      -- itself, or another module that imported it.  (Necessarily,-      -- this invoves a loop.)-      ---      -- We do this *after* filterImports, so that if you say-      --      module A where-      --         import B( AType )-      --         type AType = ...-      ---      --      module B( AType ) where-      --         import {-# SOURCE #-} A( AType )-      ---      -- then you won't get a 'B does not export AType' message.---      -- Compute new transitive dependencies-      ---      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module-      -- itself, but we DO need to include this module in 'imp_orphs' and-      -- 'imp_finsts' if it defines an orphan or instance family; thus the-      -- orph_iface/has_iface tests.--      orphans | orph_iface = ASSERT2( 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--      finsts | has_finsts = ASSERT2( 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--      pkg = moduleUnitId (mi_module iface)-      ipkg = toInstalledUnitId pkg--      -- Does this import mean we now require our own pkg-      -- to be trusted? See Note [Trust Own Package]-      ptrust = trust == Sf_Trustworthy || trust_pkg--      (dependent_mods, dependent_pkgs, pkg_trust_req)-         | pkg == thisPackage dflags =-            -- Imported module is from the home package-            -- Take its dependent modules and add imp_mod itself-            -- Take its dependent packages unchanged-            ---            -- NB: (dep_mods deps) might include a hi-boot file-            -- for the module being compiled, CM. Do *not* filter-            -- this out (as we used to), because when we've-            -- finished dealing with the direct imports we want to-            -- know if any of them depended on CM.hi-boot, in-            -- which case we should do the hi-boot consistency-            -- check.  See LoadIface.loadHiBootInterface-            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)--         | otherwise =-            -- Imported module is from another package-            -- Dump the dependent modules-            -- Add the package imp_mod comes from to the dependent packages-            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))-                   , ppr ipkg <+> ppr (dep_pkgs deps) )-            ([], (ipkg, False) : dep_pkgs deps, False)--  in ImportAvails {-          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],-          imp_orphs      = orphans,-          imp_finsts     = finsts,-          imp_dep_mods   = mkModDeps dependent_mods,-          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,-          -- Add in the imported modules trusted package-          -- requirements. ONLY do this though if we import the-          -- module as a safe import.-          -- See Note [Tracking Trust Transitively]-          -- and Note [Trust Transitive Property]-          imp_trust_pkgs = if mod_safe'-                               then S.fromList . map fst $ filter snd dependent_pkgs-                               else S.empty,-          -- Do we require our own pkg to be trusted?-          -- See Note [Trust Own Package]-          imp_trust_own_pkg = pkg_trust_req-     }---warnRedundantSourceImport :: ModuleName -> SDoc-warnRedundantSourceImport mod_name-  = text "Unnecessary {-# SOURCE #-} in the import of module"-          <+> quotes (ppr mod_name)--{--************************************************************************-*                                                                      *-\subsection{importsFromLocalDecls}-*                                                                      *-************************************************************************--From the top-level declarations of this module produce-        * the lexical environment-        * the ImportAvails-created by its bindings.--Note [Top-level Names in Template Haskell decl quotes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also: Note [Interactively-bound Ids in GHCi] in HscTypes-          Note [Looking up Exact RdrNames] in RnEnv--Consider a Template Haskell declaration quotation like this:-      module M where-        f x = h [d| f = 3 |]-When renaming the declarations inside [d| ...|], we treat the-top level binders specially in two ways--1.  We give them an Internal Name, not (as usual) an External one.-    This is done by RnEnv.newTopSrcBinder.--2.  We make them *shadow* the outer bindings.-    See Note [GlobalRdrEnv shadowing]--3. We find out whether we are inside a [d| ... |] by testing the TH-   stage. This is a slight hack, because the stage field was really-   meant for the type checker, and here we are not interested in the-   fields of Brack, hence the error thunks in thRnBrack.--}--extendGlobalRdrEnvRn :: [AvailInfo]-                     -> MiniFixityEnv-                     -> RnM (TcGblEnv, TcLclEnv)--- Updates both the GlobalRdrEnv and the FixityEnv--- We return a new TcLclEnv only because we might have to--- delete some bindings from it;--- see Note [Top-level Names in Template Haskell decl quotes]--extendGlobalRdrEnvRn avails new_fixities-  = do  { (gbl_env, lcl_env) <- getEnvs-        ; stage <- getStage-        ; isGHCi <- getIsGHCi-        ; let rdr_env  = tcg_rdr_env gbl_env-              fix_env  = tcg_fix_env gbl_env-              th_bndrs = tcl_th_bndrs lcl_env-              th_lvl   = thLevel stage--              -- Delete new_occs from global and local envs-              -- If we are in a TemplateHaskell decl bracket,-              --    we are going to shadow them-              -- See Note [GlobalRdrEnv shadowing]-              inBracket = isBrackStage stage--              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }-                           -- See Note [GlobalRdrEnv shadowing]--              lcl_env2 | inBracket = lcl_env_TH-                       | otherwise = lcl_env--              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]-              want_shadowing = isGHCi || inBracket-              rdr_env1 | want_shadowing = shadowNames rdr_env new_names-                       | otherwise      = rdr_env--              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs-                                                       [ (n, (TopLevel, th_lvl))-                                                       | n <- new_names ] }--        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres--        ; let fix_env' = foldl' extend_fix_env fix_env new_gres-              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }--        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)-        ; return (gbl_env', lcl_env3) }-  where-    new_names = concatMap availNames avails-    new_occs  = map nameOccName new_names--    -- If there is a fixity decl for the gre, add it to the fixity env-    extend_fix_env fix_env gre-      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)-      = extendNameEnv fix_env name (FixItem occ fi)-      | otherwise-      = fix_env-      where-        name = gre_name gre-        occ  = greOccName gre--    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails-    new_gres = concatMap localGREsFromAvail avails--    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv-    -- Extend the GlobalRdrEnv with a LocalDef GRE-    -- If there is already a LocalDef GRE with the same OccName,-    --    report an error and discard the new GRE-    -- This establishes INVARIANT 1 of GlobalRdrEnvs-    add_gre env gre-      | not (null dups)    -- Same OccName defined twice-      = do { addDupDeclErr (gre : dups); return env }--      | otherwise-      = return (extendGlobalRdrEnv env gre)-      where-        name = gre_name gre-        occ  = nameOccName name-        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)---{- *********************************************************************-*                                                                      *-    getLocalDeclBindersd@ returns the names for an HsDecl-             It's used for source code.--        *** See Note [The Naming story] in GHC.Hs.Decls ****-*                                                                      *-********************************************************************* -}--getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs-    -> RnM ((TcGblEnv, TcLclEnv), NameSet)--- Get all the top-level binders bound the group *except*--- for value bindings, which are treated separately--- Specifically we return AvailInfo for---      * type decls (incl constructors and record selectors)---      * class decls (including class ops)---      * associated types---      * foreign imports---      * value signatures (in hs-boot files only)--getLocalNonValBinders fixity_env-     (HsGroup { hs_valds  = binds,-                hs_tyclds = tycl_decls,-                hs_fords  = foreign_decls })-  = do  { -- Process all type/class decls *except* family instances-        ; let inst_decls = tycl_decls >>= group_instds-        ; overload_ok <- xoptM LangExt.DuplicateRecordFields-        ; (tc_avails, tc_fldss)-            <- fmap unzip $ mapM (new_tc overload_ok)-                                 (tyClGroupTyClDecls tycl_decls)-        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)-        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env-        ; setEnvs envs $ do {-            -- Bring these things into scope first-            -- See Note [Looking up family names in family instances]--          -- Process all family instances-          -- to bring new data constructors into scope-        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)-                                                   inst_decls--          -- Finish off with value binders:-          --    foreign decls and pattern synonyms for an ordinary module-          --    type sigs in case of a hs-boot file only-        ; is_boot <- tcIsHsBootOrSig-        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs-                        | otherwise = for_hs_bndrs-        ; val_avails <- mapM new_simple val_bndrs--        ; let avails    = concat nti_availss ++ val_avails-              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`-                          availsToNameSetWithSelectors tc_avails-              flds      = concat nti_fldss ++ concat tc_fldss-        ; traceRn "getLocalNonValBinders 2" (ppr avails)-        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env--        -- Extend tcg_field_env with new fields (this used to be the-        -- work of extendRecordFieldEnv)-        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds-              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)--        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])-        ; return (envs, new_bndrs) } }-  where-    ValBinds _ _val_binds val_sigs = binds--    for_hs_bndrs :: [Located RdrName]-    for_hs_bndrs = hsForeignDeclsBinders foreign_decls--    -- In a hs-boot file, the value binders come from the-    --  *signatures*, and there should be no foreign binders-    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)-                        | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]--      -- the SrcSpan attached to the input should be the span of the-      -- declaration, not just the name-    new_simple :: Located RdrName -> RnM AvailInfo-    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name-                            ; return (avail nm) }--    new_tc :: Bool -> LTyClDecl GhcPs-           -> RnM (AvailInfo, [(Name, [FieldLabel])])-    new_tc overload_ok tc_decl -- NOT for type/data instances-        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl-             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs-             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds-             ; let fld_env = case unLoc tc_decl of-                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'-                     _                            -> []-             ; return (AvailTC main_name names flds', fld_env) }---    -- Calculate the mapping from constructor names to fields, which-    -- will go in tcg_field_env. It's convenient to do this here where-    -- we are working with a single datatype definition.-    mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]-               -> [(Name, [FieldLabel])]-    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)-      where-        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr-                                       , con_args = RecCon cdflds }))-            = [( find_con_name rdr-               , concatMap find_con_decl_flds (unLoc cdflds) )]-        find_con_flds (L _ (ConDeclGADT { con_names = rdrs-                                        , con_args = RecCon flds }))-            = [ ( find_con_name rdr-                 , concatMap find_con_decl_flds (unLoc flds))-              | L _ rdr <- rdrs ]--        find_con_flds _ = []--        find_con_name rdr-          = expectJust "getLocalNonValBinders/find_con_name" $-              find (\ n -> nameOccName n == rdrNameOcc rdr) names-        find_con_decl_flds (L _ x)-          = map find_con_decl_fld (cd_fld_names x)--        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))-          = expectJust "getLocalNonValBinders/find_con_decl_fld" $-              find (\ fl -> flLabel fl == lbl) flds-          where lbl = occNameFS (rdrNameOcc rdr)-        find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec--    new_assoc :: Bool -> LInstDecl GhcPs-              -> RnM ([AvailInfo], [(Name, [FieldLabel])])-    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])-      -- type instances don't bind new names--    new_assoc overload_ok (L _ (DataFamInstD _ d))-      = do { (avail, flds) <- new_di overload_ok Nothing d-           ; return ([avail], flds) }-    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty-                                                      , cid_datafam_insts = adts })))-      = do -- First, attempt to grab the name of the class from the instance.-           -- This step could fail if the instance is not headed by a class,-           -- such as in the following examples:-           ---           -- (1) The class is headed by a bang pattern, such as in-           --     `instance !Show Int` (#3811c)-           -- (2) The class is headed by a type variable, such as in-           --     `instance c` (#16385)-           ---           -- If looking up the class name fails, then mb_cls_nm will-           -- be Nothing.-           mb_cls_nm <- runMaybeT $ do-             -- See (1) above-             L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty-             -- See (2) above-             MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr-           -- Assuming the previous step succeeded, process any associated data-           -- family instances. If the previous step failed, bail out.-           case mb_cls_nm of-             Nothing -> pure ([], [])-             Just cls_nm -> do-               (avails, fldss)-                 <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts-               pure (avails, concat fldss)-    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec-    new_assoc _ (L _ (XInstDecl nec))                 = noExtCon nec--    new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs-                   -> RnM (AvailInfo, [(Name, [FieldLabel])])-    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =-                                     HsIB { hsib_body = ti_decl }})-        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)-             ; let (bndrs, flds) = hsDataFamInstBinders dfid-             ; sub_names <- mapM newTopSrcBinder bndrs-             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds-             ; let avail    = AvailTC (unLoc main_name) sub_names flds'-                                  -- main_name is not bound here!-                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'-             ; return (avail, fld_env) }-    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec--    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs-                   -> RnM (AvailInfo, [(Name, [FieldLabel])])-    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d-getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec--newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel-newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"-newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec-newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))-  = do { selName <- newTopSrcBinder $ L loc $ field-       ; return $ qualFieldLbl { flSelector = selName } }-  where-    fieldOccName = occNameFS $ rdrNameOcc fld-    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok-    field | isExact fld = fld-              -- use an Exact RdrName as is to preserve the bindings-              -- of an already renamer-resolved field and its use-              -- sites. This is needed to correctly support record-              -- selectors in Template Haskell. See Note [Binders in-              -- Template Haskell] in Convert.hs and Note [Looking up-              -- Exact RdrNames] in RnEnv.hs.-          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)--{--Note [Looking up family names in family instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  module M where-    type family T a :: *-    type instance M.T Int = Bool--We might think that we can simply use 'lookupOccRn' when processing the type-instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in-the *same* HsGroup as the type instance declaration.  Hence, as we are-currently collecting the binders declared in that HsGroup, these binders will-not have been added to the global environment yet.--Solution is simple: process the type family declarations first, extend-the environment, and then process the type instances.---************************************************************************-*                                                                      *-\subsection{Filtering imports}-*                                                                      *-************************************************************************--@filterImports@ takes the @ExportEnv@ telling what the imported module makes-available, and filters it through the import spec (if any).--Note [Dealing with imports]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-For import M( ies ), we take the mi_exports of M, and make-   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)-One entry for each Name that M exports; the AvailInfo is the-AvailInfo exported from M that exports that Name.--The situation is made more complicated by associated types. E.g.-   module M where-     class    C a    where { data T a }-     instance C Int  where { data T Int = T1 | T2 }-     instance C Bool where { data T Int = T3 }-Then M's export_avails are (recall the AvailTC invariant from Avails.hs)-  C(C,T), T(T,T1,T2,T3)-Notice that T appears *twice*, once as a child and once as a parent. From-this list we construct a raw list including-   T -> (T, T( T1, T2, T3 ), Nothing)-   T -> (C, C( C, T ),       Nothing)-and we combine these (in function 'combine' in 'imp_occ_env' in-'filterImports') to get-   T  -> (T,  T(T,T1,T2,T3), Just C)--So the overall imp_occ_env is-   C  -> (C,  C(C,T),        Nothing)-   T  -> (T,  T(T,T1,T2,T3), Just C)-   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3--If we say-   import M( T(T1,T2) )-then we get *two* Avails:  C(T), T(T1,T2)--Note that the imp_occ_env will have entries for data constructors too,-although we never look up data constructors.--}--filterImports-    :: ModIface-    -> ImpDeclSpec                     -- The span for the entire import decl-    -> Maybe (Bool, Located [LIE GhcPs])    -- Import spec; True => hiding-    -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names-            [GlobalRdrElt])                   -- Same again, but in GRE form-filterImports iface decl_spec Nothing-  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))-  where-    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }---filterImports iface decl_spec (Just (want_hiding, L l import_items))-  = do  -- check for errors, convert RdrNames to Names-        items1 <- mapM lookup_lie import_items--        let items2 :: [(LIE GhcRn, AvailInfo)]-            items2 = concat items1-                -- NB the AvailInfo may have duplicates, and several items-                --    for the same parent; e.g N(x) and N(y)--            names  = availsToNameSetWithSelectors (map snd items2)-            keep n = not (n `elemNameSet` names)-            pruned_avails = filterAvails keep all_avails-            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }--            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails-                 | otherwise   = concatMap (gresFromIE decl_spec) items2--        return (Just (want_hiding, L l (map fst items2)), gres)-  where-    all_avails = mi_exports iface--        -- See Note [Dealing with imports]-    imp_occ_env :: OccEnv (Name,    -- the name-                           AvailInfo,   -- the export item providing the name-                           Maybe Name)  -- the parent of associated types-    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))-                                     | a <- all_avails-                                     , (n, occ) <- availNamesWithOccs a]-      where-        -- See Note [Dealing with imports]-        -- 'combine' is only called for associated data types which appear-        -- twice in the all_avails. In the example, we combine-        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)-        -- NB: the AvailTC can have fields as well as data constructors (#12127)-        combine (name1, a1@(AvailTC p1 _ _), mp1)-                (name2, a2@(AvailTC p2 _ _), mp2)-          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2-                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )-            if p1 == name1 then (name1, a1, Just p2)-                           else (name1, a2, Just p1)-        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)--    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)-    lookup_name ie rdr-       | isQual rdr              = failLookupWith (QualImportError rdr)-       | Just succ <- mb_success = return succ-       | otherwise               = failLookupWith (BadImport ie)-      where-        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)--    lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]-    lookup_lie (L loc ieRdr)-        = do (stuff, warns) <- setSrcSpan loc $-                               liftM (fromMaybe ([],[])) $-                               run_lookup (lookup_ie ieRdr)-             mapM_ emit_warning warns-             return [ (L loc ie, avail) | (ie,avail) <- stuff ]-        where-            -- Warn when importing T(..) if T was exported abstractly-            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $-              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)-            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $-              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)-            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $-              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))--            run_lookup :: IELookupM a -> TcRn (Maybe a)-            run_lookup m = case m of-              Failed err -> addErr (lookup_err_msg err) >> return Nothing-              Succeeded a -> return (Just a)--            lookup_err_msg err = case err of-              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails-              IllegalImport -> illegalImportItemErr-              QualImportError rdr -> qualImportItemErr rdr--        -- For each import item, we convert its RdrNames to Names,-        -- and at the same time construct an AvailInfo corresponding-        -- to what is actually imported by this item.-        -- Returns Nothing on error.-        -- We return a list here, because in the case of an import-        -- item like C, if we are hiding, then C refers to *both* a-        -- type/class and a data constructor.  Moreover, when we import-        -- data constructors of an associated family, we need separate-        -- AvailInfos for the data constructors and the family (as they have-        -- different parents).  See Note [Dealing with imports]-    lookup_ie :: IE GhcPs-              -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])-    lookup_ie ie = handle_bad_import $ do-      case ie of-        IEVar _ (L l n) -> do-            (name, avail, _) <- lookup_name ie $ ieWrappedName n-            return ([(IEVar noExtField (L l (replaceWrappedName n name)),-                                                  trimAvail avail name)], [])--        IEThingAll _ (L l tc) -> do-            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc-            let warns = case avail of-                          Avail {}                     -- e.g. f(..)-                            -> [DodgyImport $ ieWrappedName tc]--                          AvailTC _ subs fs-                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym-                            -> [DodgyImport $ ieWrappedName tc]--                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )-                            -> [MissingImportList]--                            | otherwise-                            -> []--                renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name))-                sub_avails = case avail of-                               Avail {}              -> []-                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]-            case mb_parent of-              Nothing     -> return ([(renamed_ie, avail)], warns)-                             -- non-associated ty/cls-              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)-                             -- associated type--        IEThingAbs _ (L l tc')-            | want_hiding   -- hiding ( C )-                       -- Here the 'C' can be a data constructor-                       --  *or* a type/class, or even both-            -> let tc = ieWrappedName tc'-                   tc_name = lookup_name ie tc-                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)-               in-               case catIELookupM [ tc_name, dc_name ] of-                 []    -> failLookupWith (BadImport ie)-                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])-            | otherwise-            -> do nameAvail <- lookup_name ie (ieWrappedName tc')-                  return ([mkIEThingAbs tc' l nameAvail]-                         , [])--        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->-          ASSERT2(null rdr_fs, ppr rdr_fs) do-           (name, avail, mb_parent)-               <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc)--           let (ns,subflds) = case avail of-                                AvailTC _ ns' subflds' -> (ns',subflds')-                                Avail _                -> panic "filterImports"--           -- Look up the children in the sub-names of the parent-           let subnames = case ns of   -- The tc is first in ns,-                            [] -> []   -- if it is there at all-                                       -- See the AvailTC Invariant in Avail.hs-                            (n1:ns1) | n1 == name -> ns1-                                     | otherwise  -> ns-           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of--             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))-                                -- We are trying to import T( a,b,c,d ), and failed-                                -- to find 'b' and 'd'.  So we make up an import item-                                -- to report as failing, namely T( b, d ).-                                -- c.f. #15412--             Succeeded (childnames, childflds) ->-               case mb_parent of-                 -- non-associated ty/cls-                 Nothing-                   -> return ([(IEThingWith noExtField (L l name') wc childnames'-                                                                 childflds,-                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],-                              [])-                   where name' = replaceWrappedName rdr_tc name-                         childnames' = map to_ie_post_rn childnames-                         -- childnames' = postrn_ies childnames-                 -- associated ty-                 Just parent-                   -> return ([(IEThingWith noExtField (L l name') wc childnames'-                                                           childflds,-                                AvailTC name (map unLoc childnames) (map unLoc childflds)),-                               (IEThingWith noExtField (L l name') wc childnames'-                                                           childflds,-                                AvailTC parent [name] [])],-                              [])-                   where name' = replaceWrappedName rdr_tc name-                         childnames' = map to_ie_post_rn childnames--        _other -> failLookupWith IllegalImport-        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed-        -- all errors.--      where-        mkIEThingAbs tc l (n, av, Nothing    )-          = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n)-        mkIEThingAbs tc l (n, _,  Just parent)-          = (IEThingAbs noExtField (L l (replaceWrappedName tc n))-             , AvailTC parent [n] [])--        handle_bad_import m = catchIELookup m $ \err -> case err of-          BadImport ie | want_hiding -> return ([], [BadImportW ie])-          _                          -> failLookupWith err--type IELookupM = MaybeErr IELookupError--data IELookupWarning-  = BadImportW (IE GhcPs)-  | MissingImportList-  | DodgyImport RdrName-  -- NB. use the RdrName for reporting a "dodgy" import--data IELookupError-  = QualImportError RdrName-  | BadImport (IE GhcPs)-  | IllegalImport--failLookupWith :: IELookupError -> IELookupM a-failLookupWith err = Failed err--catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a-catchIELookup m h = case m of-  Succeeded r -> return r-  Failed err  -> h err--catIELookupM :: [IELookupM a] -> [a]-catIELookupM ms = [ a | Succeeded a <- ms ]--{--************************************************************************-*                                                                      *-\subsection{Import/Export Utils}-*                                                                      *-************************************************************************--}---- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.-gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]-gresFromIE decl_spec (L loc ie, avail)-  = gresFromAvail prov_fn avail-  where-    is_explicit = case ie of-                    IEThingAll _ name -> \n -> n == lieWrappedName name-                    _                 -> \_ -> True-    prov_fn name-      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })-      where-        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }---{--Note [Children for duplicate record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the module--    {-# LANGUAGE DuplicateRecordFields #-}-    module M (F(foo, MkFInt, MkFBool)) where-      data family F a-      data instance F Int = MkFInt { foo :: Int }-      data instance F Bool = MkFBool { foo :: Bool }--The `foo` in the export list refers to *both* selectors! For this-reason, lookupChildren builds an environment that maps the FastString-to a list of items, rather than a single item.--}--mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]-mkChildEnv gres = foldr add emptyNameEnv gres-  where-    add gre env = case gre_par gre of-        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre-        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre-        NoParent       -> env--findChildren :: NameEnv [a] -> Name -> [a]-findChildren env n = lookupNameEnv env n `orElse` []--lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]-               -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed-                           ([Located Name], [Located FieldLabel])--- (lookupChildren all_kids rdr_items) maps each rdr_item to its--- corresponding Name all_kids, if the former exists--- The matching is done by FastString, not OccName, so that---    Cls( meth, AssocTy )--- will correctly find AssocTy among the all_kids of Cls, even though--- the RdrName for AssocTy may have a (bogus) DataName namespace--- (Really the rdr_items should be FastStrings in the first place.)-lookupChildren all_kids rdr_items-  | null fails-  = Succeeded (fmap concat (partitionEithers oks))-       -- This 'fmap concat' trickily applies concat to the /second/ component-       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])-  | otherwise-  = Failed fails-  where-    mb_xs = map doOne rdr_items-    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]-    oks   = [ ok      | Succeeded ok   <- mb_xs ]-    oks :: [Either (Located Name) [Located FieldLabel]]--    doOne item@(L l r)-       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of-           Just [Left n]            -> Succeeded (Left (L l n))-           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))-           _                        -> Failed    item--    -- See Note [Children for duplicate record fields]-    kid_env = extendFsEnvList_C (++) emptyFsEnv-              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]-------------------------------------{--*********************************************************-*                                                       *-\subsection{Unused names}-*                                                       *-*********************************************************--}--reportUnusedNames :: TcGblEnv -> RnM ()-reportUnusedNames gbl_env-  = do  { keep <- readTcRef (tcg_keep gbl_env)-        ; traceRn "RUN" (ppr (tcg_dus gbl_env))-        ; warnUnusedImportDecls gbl_env-        ; warnUnusedTopBinds $ unused_locals keep-        ; warnMissingSignatures gbl_env }-  where-    used_names :: NameSet -> NameSet-    used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep-    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used-    -- Hence findUses--    -- Collect the defined names from the in-scope environment-    defined_names :: [GlobalRdrElt]-    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)--    kids_env = mkChildEnv defined_names-    -- This is done in mkExports too; duplicated work--    gre_is_used :: NameSet -> GlobalRdrElt -> Bool-    gre_is_used used_names (GRE {gre_name = name})-        = name `elemNameSet` used_names-          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)-                -- A use of C implies a use of T,-                -- if C was brought into scope by T(..) or T(C)--    -- Filter out the ones that are-    --  (a) defined in this module, and-    --  (b) not defined by a 'deriving' clause-    -- The latter have an Internal Name, so we can filter them out easily-    unused_locals :: NameSet -> [GlobalRdrElt]-    unused_locals keep =-      let -- Note that defined_and_used, defined_but_not_used-          -- are both [GRE]; that's why we need defined_and_used-          -- rather than just used_names-          _defined_and_used, defined_but_not_used :: [GlobalRdrElt]-          (_defined_and_used, defined_but_not_used)-              = partition (gre_is_used (used_names keep)) defined_names--      in filter is_unused_local defined_but_not_used-    is_unused_local :: GlobalRdrElt -> Bool-    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)--{- *********************************************************************-*                                                                      *-              Missing signatures-*                                                                      *-********************************************************************* -}---- | Warn the user about top level binders that lack type signatures.--- Called /after/ type inference, so that we can report the--- inferred type of the function-warnMissingSignatures :: TcGblEnv -> RnM ()-warnMissingSignatures gbl_env-  = do { let exports = availsToNameSet (tcg_exports gbl_env)-             sig_ns  = tcg_sigs gbl_env-               -- We use sig_ns to exclude top-level bindings that are generated by GHC-             binds    = collectHsBindsBinders $ tcg_binds gbl_env-             pat_syns = tcg_patsyns gbl_env--         -- Warn about missing signatures-         -- Do this only when we have a type to offer-       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures-       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures-       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures--       ; let add_sig_warns-               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures-               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures-               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures-               | otherwise          = return ()--             add_warns flag-                = when warn_pat_syns-                       (mapM_ add_pat_syn_warn pat_syns) >>-                  when (warn_missing_sigs || warn_only_exported)-                       (mapM_ add_bind_warn binds)-                where-                  add_pat_syn_warn p-                    = add_warn name $-                      hang (text "Pattern synonym with no type signature:")-                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)-                    where-                      name  = patSynName p-                      pp_ty = pprPatSynType p--                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()-                  add_bind_warn id-                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?-                         ; let name    = idName id-                               (_, ty) = tidyOpenType env (idType id)-                               ty_msg  = pprSigmaType ty-                         ; add_warn name $-                           hang (text "Top-level binding with no type signature:")-                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }--                  add_warn name msg-                    = when (name `elemNameSet` sig_ns && export_check name)-                           (addWarnAt (Reason flag) (getSrcSpan name) msg)--                  export_check name-                    = not warn_only_exported || name `elemNameSet` exports--       ; add_sig_warns }---{--*********************************************************-*                                                       *-\subsection{Unused imports}-*                                                       *-*********************************************************--This code finds which import declarations are unused.  The-specification and implementation notes are here:-  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports--See also Note [Choosing the best import declaration] in RdrName--}--type ImportDeclUsage-   = ( LImportDecl GhcRn   -- The import declaration-     , [GlobalRdrElt]      -- What *is* used (normalised)-     , [Name] )            -- What is imported but *not* used--warnUnusedImportDecls :: TcGblEnv -> RnM ()-warnUnusedImportDecls gbl_env-  = do { uses <- readMutVar (tcg_used_gres gbl_env)-       ; let user_imports = filterOut-                              (ideclImplicit . unLoc)-                              (tcg_rn_imports gbl_env)-                -- This whole function deals only with *user* imports-                -- both for warning about unnecessary ones, and for-                -- deciding the minimal ones-             rdr_env = tcg_rdr_env gbl_env-             fld_env = mkFieldEnv rdr_env--       ; let usage :: [ImportDeclUsage]-             usage = findImportUsage user_imports uses--       ; traceRn "warnUnusedImportDecls" $-                       (vcat [ text "Uses:" <+> ppr uses-                             , text "Import usage" <+> ppr usage])--       ; whenWOptM Opt_WarnUnusedImports $-         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage--       ; whenGOptM Opt_D_dump_minimal_imports $-         printMinimalImports usage }--findImportUsage :: [LImportDecl GhcRn]-                -> [GlobalRdrElt]-                -> [ImportDeclUsage]--findImportUsage imports used_gres-  = map unused_decl imports-  where-    import_usage :: ImportMap-    import_usage = mkImportMap used_gres--    unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))-      = (decl, used_gres, nameSetElemsStable unused_imps)-      where-        used_gres = Map.lookup (srcSpanEnd loc) import_usage-                               -- srcSpanEnd: see Note [The ImportMap]-                    `orElse` []--        used_names   = mkNameSet (map      gre_name        used_gres)-        used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)--        unused_imps   -- Not trivial; see eg #7454-          = case imps of-              Just (False, L _ imp_ies) ->-                                 foldr (add_unused . unLoc) emptyNameSet imp_ies-              _other -> emptyNameSet -- No explicit import list => no unused-name list--        add_unused :: IE GhcRn -> NameSet -> NameSet-        add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc-        add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc-        add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc-        add_unused (IEThingWith _ p wc ns fs) acc =-          add_wc_all (add_unused_with pn xs acc)-          where pn = lieWrappedName p-                xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs-                add_wc_all = case wc of-                            NoIEWildcard -> id-                            IEWildcard _ -> add_unused_all pn-        add_unused _ acc = acc--        add_unused_name n acc-          | n `elemNameSet` used_names = acc-          | otherwise                  = acc `extendNameSet` n-        add_unused_all n acc-          | n `elemNameSet` used_names   = acc-          | n `elemNameSet` used_parents = acc-          | otherwise                    = acc `extendNameSet` n-        add_unused_with p ns acc-          | all (`elemNameSet` acc1) ns = add_unused_name p acc1-          | otherwise = acc1-          where-            acc1 = foldr add_unused_name acc ns-       -- If you use 'signum' from Num, then the user may well have-       -- imported Num(signum).  We don't want to complain that-       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.-    unused_decl (L _ (XImportDecl nec)) = noExtCon nec---{- Note [The ImportMap]-~~~~~~~~~~~~~~~~~~~~~~~-The ImportMap is a short-lived intermediate data structure records, for-each import declaration, what stuff brought into scope by that-declaration is actually used in the module.--The SrcLoc is the location of the END of a particular 'import'-declaration.  Why *END*?  Because we don't want to get confused-by the implicit Prelude import. Consider (#7476) the module-    import Foo( foo )-    main = print foo-There is an implicit 'import Prelude(print)', and it gets a SrcSpan-of line 1:1 (just the point, not a span). If we use the *START* of-the SrcSpan to identify the import decl, we'll confuse the implicit-import Prelude with the explicit 'import Foo'.  So we use the END.-It's just a cheap hack; we could equally well use the Span too.--The [GlobalRdrElt] are the things imported from that decl.--}--type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]-     -- If loc :-> gres, then-     --   'loc' = the end loc of the bestImport of each GRE in 'gres'--mkImportMap :: [GlobalRdrElt] -> ImportMap--- For each of a list of used GREs, find all the import decls that brought--- it into scope; choose one of them (bestImport), and record--- the RdrName in that import decl's entry in the ImportMap-mkImportMap gres-  = foldr add_one Map.empty gres-  where-    add_one gre@(GRE { gre_imp = imp_specs }) imp_map-       = Map.insertWith add decl_loc [gre] imp_map-       where-          best_imp_spec = bestImport imp_specs-          decl_loc      = srcSpanEnd (is_dloc (is_decl best_imp_spec))-                        -- For srcSpanEnd see Note [The ImportMap]-          add _ gres = gre : gres--warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)-                 -> ImportDeclUsage -> RnM ()-warnUnusedImport flag fld_env (L loc decl, used, unused)--  -- Do not warn for 'import M()'-  | Just (False,L _ []) <- ideclHiding decl-  = return ()--  -- Note [Do not warn about Prelude hiding]-  | Just (True, L _ hides) <- ideclHiding decl-  , not (null hides)-  , pRELUDE_NAME == unLoc (ideclName decl)-  = return ()--  -- Nothing used; drop entire declaration-  | null used-  = addWarnAt (Reason flag) loc msg1--  -- Everything imported is used; nop-  | null unused-  = return ()--  -- Some imports are unused-  | otherwise-  = addWarnAt (Reason flag) loc  msg2--  where-    msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant-                , nest 2 (text "except perhaps to import instances from"-                                   <+> quotes pp_mod)-                , text "To import instances alone, use:"-                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]-    msg2 = sep [ pp_herald <+> quotes sort_unused-               , text "from module" <+> quotes pp_mod <+> is_redundant]-    pp_herald  = text "The" <+> pp_qual <+> text "import of"-    pp_qual-      | isImportDeclQualified (ideclQualified decl)= text "qualified"-      | otherwise                                  = Outputable.empty-    pp_mod       = ppr (unLoc (ideclName decl))-    is_redundant = text "is redundant"--    -- In warning message, pretty-print identifiers unqualified unconditionally-    -- to improve the consistent for ambiguous/unambiguous identifiers.-    -- See trac#14881.-    ppr_possible_field n = case lookupNameEnv fld_env n of-                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)-                               Nothing  -> pprNameUnqualified n--    -- Print unused names in a deterministic (lexicographic) order-    sort_unused :: SDoc-    sort_unused = pprWithCommas ppr_possible_field $-                  sortBy (comparing nameOccName) unused--{--Note [Do not warn about Prelude hiding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not warn about-   import Prelude hiding( x, y )-because even if nothing else from Prelude is used, it may be essential to hide-x,y to avoid name-shadowing warnings.  Example (#9061)-   import Prelude hiding( log )-   f x = log where log = ()----Note [Printing minimal imports]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To print the minimal imports we walk over the user-supplied import-decls, and simply trim their import lists.  NB that--  * We do *not* change the 'qualified' or 'as' parts!--  * We do not disard a decl altogether; we might need instances-    from it.  Instead we just trim to an empty import list--}--getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]-getMinimalImports = mapM mk_minimal-  where-    mk_minimal (L l decl, used_gres, unused)-      | null unused-      , Just (False, _) <- ideclHiding decl-      = return (L l decl)-      | otherwise-      = do { let ImportDecl { ideclName    = L _ mod_name-                            , ideclSource  = is_boot-                            , ideclPkgQual = mb_pkg } = decl-           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)-           ; let used_avails = gresToAvailInfo used_gres-                 lies = map (L l) (concatMap (to_ie iface) used_avails)-           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }-      where-        doc = text "Compute minimal imports for" <+> ppr decl--    to_ie :: ModIface -> AvailInfo -> [IE GhcRn]-    -- The main trick here is that if we're importing all the constructors-    -- we want to say "T(..)", but if we're importing only a subset we want-    -- to say "T(A,B,C)".  So we have to find out what the module exports.-    to_ie _ (Avail n)-       = [IEVar noExtField (to_ie_post_rn $ noLoc n)]-    to_ie _ (AvailTC n [m] [])-       | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)]-    to_ie iface (AvailTC n ns fs)-      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface-                 , x == n-                 , x `elem` xs    -- Note [Partial export]-                 ] of-           [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)]-                | otherwise   ->-                   [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard-                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))-                                (map noLoc fs)]-                                          -- Note [Overloaded field import]-           _other | all_non_overloaded fs-                           -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns-                                 ++ map flSelector fs-                  | otherwise ->-                      [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard-                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))-                                (map noLoc fs)]-        where--          fld_lbls = map flLabel fs--          all_used (avail_occs, avail_flds)-              = all (`elem` ns) avail_occs-                    && all (`elem` fld_lbls) (map flLabel avail_flds)--          all_non_overloaded = all (not . flIsOverloaded)--printMinimalImports :: [ImportDeclUsage] -> RnM ()--- See Note [Printing minimal imports]-printMinimalImports imports_w_usage-  = do { imports' <- getMinimalImports imports_w_usage-       ; this_mod <- getModule-       ; dflags   <- getDynFlags-       ; liftIO $-         do { h <- openFile (mkFilename dflags this_mod) WriteMode-            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }-              -- The neverQualify is important.  We are printing Names-              -- but they are in the context of an 'import' decl, and-              -- we never qualify things inside there-              -- E.g.   import Blag( f, b )-              -- not    import Blag( Blag.f, Blag.g )!-       }-  where-    mkFilename dflags this_mod-      | Just d <- dumpDir dflags = d </> basefn-      | otherwise                = basefn-      where-        basefn = moduleNameString (moduleName this_mod) ++ ".imports"---to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name-to_ie_post_rn_var (L l n)-  | isDataOcc $ occName n = L l (IEPattern (L l n))-  | otherwise             = L l (IEName    (L l n))---to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name-to_ie_post_rn (L l n)-  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))-  | otherwise                   = L l (IEName (L l n))-  where occ = occName n--{--Note [Partial export]-~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   module A( op ) where-     class C a where-       op :: a -> a--   module B where-   import A-   f = ..op...--Then the minimal import for module B is-   import A( op )-not-   import A( C( op ) )-which we would usually generate if C was exported from B.  Hence-the (x `elem` xs) test when deciding what to generate.---Note [Overloaded field import]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On the other hand, if we have--    {-# LANGUAGE DuplicateRecordFields #-}-    module A where-      data T = MkT { foo :: Int }--    module B where-      import A-      f = ...foo...--then the minimal import for module B must be-    import A ( T(foo) )-because when DuplicateRecordFields is enabled, field selectors are-not in scope without their enclosing datatype.---************************************************************************-*                                                                      *-\subsection{Errors}-*                                                                      *-************************************************************************--}--qualImportItemErr :: RdrName -> SDoc-qualImportItemErr rdr-  = hang (text "Illegal qualified name in import item:")-       2 (ppr rdr)--badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc-badImportItemErrStd iface decl_spec ie-  = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,-         text "does not export", quotes (ppr ie)]-  where-    source_import | mi_boot iface = text "(hi-boot interface)"-                  | otherwise     = Outputable.empty--badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs-                        -> SDoc-badImportItemErrDataCon dataType_occ iface decl_spec ie-  = vcat [ text "In module"-             <+> quotes (ppr (is_mod decl_spec))-             <+> source_import <> colon-         , nest 2 $ quotes datacon-             <+> text "is a data constructor of"-             <+> quotes dataType-         , text "To import it use"-         , nest 2 $ text "import"-             <+> ppr (is_mod decl_spec)-             <> parens_sp (dataType <> parens_sp datacon)-         , text "or"-         , nest 2 $ text "import"-             <+> ppr (is_mod decl_spec)-             <> parens_sp (dataType <> text "(..)")-         ]-  where-    datacon_occ = rdrNameOcc $ ieName ie-    datacon = parenSymOcc datacon_occ (ppr datacon_occ)-    dataType = parenSymOcc dataType_occ (ppr dataType_occ)-    source_import | mi_boot iface = text "(hi-boot interface)"-                  | otherwise     = Outputable.empty-    parens_sp d = parens (space <> d <> space)  -- T( f,g )--badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc-badImportItemErr iface decl_spec ie avails-  = case find checkIfDataCon avails of-      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie-      Nothing  -> badImportItemErrStd iface decl_spec ie-  where-    checkIfDataCon (AvailTC _ ns _) =-      case find (\n -> importedFS == nameOccNameFS n) ns of-        Just n  -> isDataConName n-        Nothing -> False-    checkIfDataCon _ = False-    availOccName = nameOccName . availName-    nameOccNameFS = occNameFS . nameOccName-    importedFS = occNameFS . rdrNameOcc $ ieName ie--illegalImportItemErr :: SDoc-illegalImportItemErr = text "Illegal import item"--dodgyImportWarn :: RdrName -> SDoc-dodgyImportWarn item-  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)--dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc-dodgyMsg kind tc ie-  = sep [ text "The" <+> kind <+> ptext (sLit "item")-                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))-                     <+> quotes (ppr ie)-                <+> text "suggests that",-          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",-          text "but it has none" ]--dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noExtField ii-  where-    ii :: LIEWrappedName (IdP (GhcPass p))-    ii = noLoc (IEName $ noLoc tc)---addDupDeclErr :: [GlobalRdrElt] -> TcRn ()-addDupDeclErr [] = panic "addDupDeclErr: empty list"-addDupDeclErr gres@(gre : _)-  = addErrAt (getSrcSpan (last sorted_names)) $-    -- Report the error at the later location-    vcat [text "Multiple declarations of" <+>-             quotes (ppr (nameOccName name)),-             -- NB. print the OccName, not the Name, because the-             -- latter might not be in scope in the RdrEnv and so will-             -- be printed qualified.-          text "Declared at:" <+>-                   vcat (map (ppr . nameSrcLoc) sorted_names)]-  where-    name = gre_name gre-    sorted_names = sortWith nameSrcLoc (map gre_name gres)----missingImportListWarn :: ModuleName -> SDoc-missingImportListWarn mod-  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")--missingImportListItem :: IE GhcPs -> SDoc-missingImportListItem ie-  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")--moduleWarn :: ModuleName -> WarningTxt -> SDoc-moduleWarn mod (WarningTxt _ txt)-  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]-moduleWarn mod (DeprecatedTxt _ txt)-  = sep [ text "Module" <+> quotes (ppr mod)-                                <+> text "is deprecated:",-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]--packageImportErr :: SDoc-packageImportErr-  = text "Package-qualified imports are not enabled; use PackageImports"---- This data decl will parse OK---      data T = a Int--- treating "a" as the constructor.--- It is really hard to make the parser spot this malformation.--- So the renamer has to check that the constructor is legal------ We can get an operator as the constructor, even in the prefix form:---      data T = :% Int Int--- from interface files, which always print in prefix form--checkConName :: RdrName -> TcRn ()-checkConName name = checkErr (isRdrDataCon name) (badDataCon name)--badDataCon :: RdrName -> SDoc-badDataCon name-   = hsep [text "Illegal data constructor name", quotes (ppr name)]
− compiler/rename/RnPat.hs 
@@ -1,897 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[RnPat]{Renaming of patterns}--Basically dependency analysis.--Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In-general, all of these functions return a renamed thing, and a set of-free variables.--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveFunctor #-}--module RnPat (-- main entry points-              rnPat, rnPats, rnBindPat, rnPatAndThen,--              NameMaker, applyNameMaker,     -- a utility for making names:-              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,-                                             --   sometimes we want to make top (qualified) names.-              isTopRecNameMaker,--              rnHsRecFields, HsRecFieldContext(..),-              rnHsRecUpdFields,--              -- CpsRn monad-              CpsRn, liftCps,--              -- Literals-              rnLit, rnOverLit,--             -- Pattern Error messages that are also used elsewhere-             checkTupSize, patSigErr-             ) where---- ENH: thin imports to only what is necessary for patterns--import GhcPrelude--import {-# SOURCE #-} RnExpr ( rnLExpr )-import {-# SOURCE #-} RnSplice ( rnSplicePat )--#include "HsVersions.h"--import GHC.Hs-import TcRnMonad-import TcHsSyn             ( hsOverLitName )-import RnEnv-import RnFixity-import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames-                           , warnUnusedMatches, newLocalBndrRn-                           , checkUnusedRecordWildcard-                           , checkDupNames, checkDupAndShadowedNames-                           , checkTupSize , unknownSubordinateErr )-import RnTypes-import PrelNames-import Name-import NameSet-import RdrName-import BasicTypes-import Util-import ListSetOps          ( removeDups )-import Outputable-import SrcLoc-import Literal             ( inCharRange )-import TysWiredIn          ( nilDataCon )-import DataCon-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad       ( when, ap, guard )-import qualified Data.List.NonEmpty as NE-import Data.Ratio--{--*********************************************************-*                                                      *-        The CpsRn Monad-*                                                      *-*********************************************************--Note [CpsRn monad]-~~~~~~~~~~~~~~~~~~-The CpsRn monad uses continuation-passing style to support this-style of programming:--        do { ...-           ; ns <- bindNames rs-           ; ...blah... }--   where rs::[RdrName], ns::[Name]--The idea is that '...blah...'-  a) sees the bindings of ns-  b) returns the free variables it mentions-     so that bindNames can report unused ones--In particular,-    mapM rnPatAndThen [p1, p2, p3]-has a *left-to-right* scoping: it makes the binders in-p1 scope over p2,p3.--}--newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))-                                            -> RnM (r, FreeVars) }-        deriving (Functor)-        -- See Note [CpsRn monad]--instance Applicative CpsRn where-    pure x = CpsRn (\k -> k x)-    (<*>) = ap--instance Monad CpsRn where-  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))--runCps :: CpsRn a -> RnM (a, FreeVars)-runCps (CpsRn m) = m (\r -> return (r, emptyFVs))--liftCps :: RnM a -> CpsRn a-liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)--liftCpsFV :: RnM (a, FreeVars) -> CpsRn a-liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing-                                     ; (r,fvs2) <- k v-                                     ; return (r, fvs1 `plusFV` fvs2) })--wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)--- Set the location, and also wrap it around the value returned-wrapSrcSpanCps fn (L loc a)-  = CpsRn (\k -> setSrcSpan loc $-                 unCpsRn (fn a) $ \v ->-                 k (L loc v))--lookupConCps :: Located RdrName -> CpsRn (Located Name)-lookupConCps con_rdr-  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr-                    ; (r, fvs) <- k con_name-                    ; return (r, addOneFV fvs (unLoc con_name)) })-    -- We add the constructor name to the free vars-    -- See Note [Patterns are uses]--{--Note [Patterns are uses]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  module Foo( f, g ) where-  data T = T1 | T2--  f T1 = True-  f T2 = False--  g _ = T1--Arguably we should report T2 as unused, even though it appears in a-pattern, because it never occurs in a constructed position.  See-#7336.-However, implementing this in the face of pattern synonyms would be-less straightforward, since given two pattern synonyms--  pattern P1 <- P2-  pattern P2 <- ()--we need to observe the dependency between P1 and P2 so that type-checking can be done in the correct order (just like for value-bindings). Dependencies between bindings is analyzed in the renamer,-where we don't know yet whether P2 is a constructor or a pattern-synonym. So for now, we do report conid occurrences in patterns as-uses.--*********************************************************-*                                                      *-        Name makers-*                                                      *-*********************************************************--Externally abstract type of name makers,-which is how you go from a RdrName to a Name--}--data NameMaker-  = LamMk       -- Lambdas-      Bool      -- True <=> report unused bindings-                --   (even if True, the warning only comes out-                --    if -Wunused-matches is on)--  | LetMk       -- Let bindings, incl top level-                -- Do *not* check for unused bindings-      TopLevelFlag-      MiniFixityEnv--topRecNameMaker :: MiniFixityEnv -> NameMaker-topRecNameMaker fix_env = LetMk TopLevel fix_env--isTopRecNameMaker :: NameMaker -> Bool-isTopRecNameMaker (LetMk TopLevel _) = True-isTopRecNameMaker _ = False--localRecNameMaker :: MiniFixityEnv -> NameMaker-localRecNameMaker fix_env = LetMk NotTopLevel fix_env--matchNameMaker :: HsMatchContext a -> NameMaker-matchNameMaker ctxt = LamMk report_unused-  where-    -- Do not report unused names in interactive contexts-    -- i.e. when you type 'x <- e' at the GHCi prompt-    report_unused = case ctxt of-                      StmtCtxt GhciStmtCtxt -> False-                      -- also, don't warn in pattern quotes, as there-                      -- is no RHS where the variables can be used!-                      ThPatQuote            -> False-                      _                     -> True--rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)-rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)--newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)-newPatLName name_maker rdr_name@(L loc _)-  = do { name <- newPatName name_maker rdr_name-       ; return (L loc name) }--newPatName :: NameMaker -> Located RdrName -> CpsRn Name-newPatName (LamMk report_unused) rdr_name-  = CpsRn (\ thing_inside ->-        do { name <- newLocalBndrRn rdr_name-           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)-           ; when report_unused $ warnUnusedMatches [name] fvs-           ; return (res, name `delFV` fvs) })--newPatName (LetMk is_top fix_env) rdr_name-  = CpsRn (\ thing_inside ->-        do { name <- case is_top of-                       NotTopLevel -> newLocalBndrRn rdr_name-                       TopLevel    -> newTopSrcBinder rdr_name-           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here-                                        -- See Note [View pattern usage]-             addLocalFixities fix_env [name] $-             thing_inside name })--    -- Note: the bindLocalNames is somewhat suspicious-    --       because it binds a top-level name as a local name.-    --       however, this binding seems to work, and it only exists for-    --       the duration of the patterns and the continuation;-    --       then the top-level name is added to the global env-    --       before going on to the RHSes (see RnSource.hs).--{--Note [View pattern usage]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  let (r, (r -> x)) = x in ...-Here the pattern binds 'r', and then uses it *only* in the view pattern.-We want to "see" this use, and in let-bindings we collect all uses and-report unused variables at the binding level. So we must use bindLocalNames-here, *not* bindLocalNameFV.  #3943.---Note [Don't report shadowing for pattern synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is one special context where a pattern doesn't introduce any new binders --pattern synonym declarations. Therefore we don't check to see if pattern-variables shadow existing identifiers as they are never bound to anything-and have no scope.--Without this check, there would be quite a cryptic warning that the `x`-in the RHS of the pattern synonym declaration shadowed the top level `x`.--```-x :: ()-x = ()--pattern P x = Just x-```--See #12615 for some more examples.--*********************************************************-*                                                      *-        External entry points-*                                                      *-*********************************************************--There are various entry points to renaming patterns, depending on- (1) whether the names created should be top-level names or local names- (2) whether the scope of the names is entirely given in a continuation-     (e.g., in a case or lambda, but not in a let or at the top-level,-      because of the way mutually recursive bindings are handled)- (3) whether the a type signature in the pattern can bind-        lexically-scoped type variables (for unpacking existential-        type vars in data constructors)- (4) whether we do duplicate and unused variable checking- (5) whether there are fixity declarations associated with the names-     bound by the patterns that need to be brought into scope with them.-- Rather than burdening the clients of this module with all of these choices,- we export the three points in this design space that we actually need:--}---- ----------- Entry point 1: rnPats ---------------------- Binds local names; the scope of the bindings is entirely in the thing_inside---   * allows type sigs to bind type vars---   * local namemaker---   * unused and duplicate checking---   * no fixities-rnPats :: HsMatchContext Name -- for error messages-       -> [LPat GhcPs]-       -> ([LPat GhcRn] -> RnM (a, FreeVars))-       -> RnM (a, FreeVars)-rnPats ctxt pats thing_inside-  = do  { envs_before <- getRdrEnvs--          -- (1) rename the patterns, bringing into scope all of the term variables-          -- (2) then do the thing inside.-        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do-        { -- Check for duplicated and shadowed names-          -- Must do this *after* renaming the patterns-          -- See Note [Collect binders only after renaming] in GHC.Hs.Utils-          -- Because we don't bind the vars all at once, we can't-          --    check incrementally for duplicates;-          -- Nor can we check incrementally for shadowing, else we'll-          --    complain *twice* about duplicates e.g. f (x,x) = ...-          ---          -- See note [Don't report shadowing for pattern synonyms]-        ; let bndrs = collectPatsBinders pats'-        ; addErrCtxt doc_pat $-          if isPatSynCtxt ctxt-             then checkDupNames bndrs-             else checkDupAndShadowedNames envs_before bndrs-        ; thing_inside pats' } }-  where-    doc_pat = text "In" <+> pprMatchContext ctxt--rnPat :: HsMatchContext Name -- for error messages-      -> LPat GhcPs-      -> (LPat GhcRn -> RnM (a, FreeVars))-      -> RnM (a, FreeVars)     -- Variables bound by pattern do not-                               -- appear in the result FreeVars-rnPat ctxt pat thing_inside-  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')--applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)-applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)-                           ; return n }---- ----------- Entry point 2: rnBindPat ---------------------- Binds local names; in a recursive scope that involves other bound vars---      e.g let { (x, Just y) = e1; ... } in ...---   * does NOT allows type sig to bind type vars---   * local namemaker---   * no unused and duplicate checking---   * fixities might be coming in-rnBindPat :: NameMaker-          -> LPat GhcPs-          -> RnM (LPat GhcRn, FreeVars)-   -- Returned FreeVars are the free variables of the pattern,-   -- of course excluding variables bound by this pattern--rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)--{--*********************************************************-*                                                      *-        The main event-*                                                      *-*********************************************************--}---- ----------- Entry point 3: rnLPatAndThen ---------------------- General version: parametrized by how you make new names--rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]-rnLPatsAndThen mk = mapM (rnLPatAndThen mk)-  -- Despite the map, the monad ensures that each pattern binds-  -- variables that may be mentioned in subsequent patterns in the list------------------------- The workhorse-rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)-rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat--rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)-rnPatAndThen _  (WildPat _)   = return (WildPat noExtField)-rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat-                                     ; return (ParPat x pat') }-rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat-                                     ; return (LazyPat x pat') }-rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat-                                     ; return (BangPat x pat') }-rnPatAndThen mk (VarPat x (L l rdr))-    = do { loc <- liftCps getSrcSpanM-         ; name <- newPatName mk (L loc rdr)-         ; return (VarPat x (L l name)) }-     -- we need to bind pattern variables for view pattern expressions-     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)--rnPatAndThen mk (SigPat x pat sig)-  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is-  -- important to rename its type signature _before_ renaming the rest of the-  -- pattern, so that type variables are first bound by the _outermost_ pattern-  -- type signature they occur in. This keeps the type checker happy when-  -- pattern type signatures happen to be nested (#7827)-  ---  -- f ((Just (x :: a) :: Maybe a)-  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here-  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here-  = do { sig' <- rnHsSigCps sig-       ; pat' <- rnLPatAndThen mk pat-       ; return (SigPat x pat' sig' ) }--rnPatAndThen mk (LitPat x lit)-  | HsString src s <- lit-  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)-       ; if ovlStr-         then rnPatAndThen mk-                           (mkNPat (noLoc (mkHsIsString src s))-                                      Nothing)-         else normal_lit }-  | otherwise = normal_lit-  where-    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }--rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)-  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit-       ; mb_neg' -- See Note [Negative zero]-           <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName-                                ; return (Just neg, fvs) }-                  positive = return (Nothing, emptyFVs)-              in liftCpsFV $ case (mb_neg , mb_neg') of-                                  (Nothing, Just _ ) -> negative-                                  (Just _ , Nothing) -> negative-                                  (Nothing, Nothing) -> positive-                                  (Just _ , Just _ ) -> positive-       ; eq' <- liftCpsFV $ lookupSyntaxName eqName-       ; return (NPat x (L l lit') mb_neg' eq') }--rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )-  = do { new_name <- newPatName mk rdr-       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]-                                                -- We skip negateName as-                                                -- negative zero doesn't make-                                                -- sense in n + k patterns-       ; minus <- liftCpsFV $ lookupSyntaxName minusName-       ; ge    <- liftCpsFV $ lookupSyntaxName geName-       ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)-                             (L l lit') lit' ge minus) }-                -- The Report says that n+k patterns must be in Integral--rnPatAndThen mk (AsPat x rdr pat)-  = do { new_name <- newPatLName mk rdr-       ; pat' <- rnLPatAndThen mk pat-       ; return (AsPat x new_name pat') }--rnPatAndThen mk p@(ViewPat x expr pat)-  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns-                      ; checkErr vp_flag (badViewPat p) }-         -- Because of the way we're arranging the recursive calls,-         -- this will be in the right context-       ; expr' <- liftCpsFV $ rnLExpr expr-       ; pat' <- rnLPatAndThen mk pat-       -- Note: at this point the PreTcType in ty can only be a placeHolder-       -- ; return (ViewPat expr' pat' ty) }-       ; return (ViewPat x expr' pat') }--rnPatAndThen mk (ConPatIn con stuff)-   -- rnConPatAndThen takes care of reconstructing the pattern-   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.-  = case unLoc con == nameRdrName (dataConName nilDataCon) of-      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists-                    ; if ol_flag then rnPatAndThen mk (ListPat noExtField [])-                                 else rnConPatAndThen mk con stuff}-      False   -> rnConPatAndThen mk con stuff--rnPatAndThen mk (ListPat _ pats)-  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists-       ; pats' <- rnLPatsAndThen mk pats-       ; case opt_OverloadedLists of-          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName-                     ; return (ListPat (Just to_list_name) pats')}-          False -> return (ListPat Nothing pats') }--rnPatAndThen mk (TuplePat x pats boxed)-  = do { liftCps $ checkTupSize (length pats)-       ; pats' <- rnLPatsAndThen mk pats-       ; return (TuplePat x pats' boxed) }--rnPatAndThen mk (SumPat x pat alt arity)-  = do { pat <- rnLPatAndThen mk pat-       ; return (SumPat x pat alt arity)-       }---- If a splice has been run already, just rename the result.-rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))-  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat--rnPatAndThen mk (SplicePat _ splice)-  = do { eith <- liftCpsFV $ rnSplicePat splice-       ; case eith of   -- See Note [rnSplicePat] in RnSplice-           Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed-           Right already_renamed -> return already_renamed }--rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)------------------------rnConPatAndThen :: NameMaker-                -> Located RdrName    -- the constructor-                -> HsConPatDetails GhcPs-                -> CpsRn (Pat GhcRn)--rnConPatAndThen mk con (PrefixCon pats)-  = do  { con' <- lookupConCps con-        ; pats' <- rnLPatsAndThen mk pats-        ; return (ConPatIn con' (PrefixCon pats')) }--rnConPatAndThen mk con (InfixCon pat1 pat2)-  = do  { con' <- lookupConCps con-        ; pat1' <- rnLPatAndThen mk pat1-        ; pat2' <- rnLPatAndThen mk pat2-        ; fixity <- liftCps $ lookupFixityRn (unLoc con')-        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }--rnConPatAndThen mk con (RecCon rpats)-  = do  { con' <- lookupConCps con-        ; rpats' <- rnHsRecPatsAndThen mk con' rpats-        ; return (ConPatIn con' (RecCon rpats')) }--checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()-checkUnusedRecordWildcardCps loc dotdot_names =-  CpsRn (\thing -> do-                    (r, fvs) <- thing ()-                    checkUnusedRecordWildcard loc fvs dotdot_names-                    return (r, fvs) )----------------------rnHsRecPatsAndThen :: NameMaker-                   -> Located Name      -- Constructor-                   -> HsRecFields GhcPs (LPat GhcPs)-                   -> CpsRn (HsRecFields GhcRn (LPat GhcRn))-rnHsRecPatsAndThen mk (L _ con)-     hs_rec_fields@(HsRecFields { rec_dotdot = dd })-  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat-                                            hs_rec_fields-       ; flds' <- mapM rn_field (flds `zip` [1..])-       ; check_unused_wildcard (implicit_binders flds' <$> dd)-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }-  where-    mkVarPat l n = VarPat noExtField (L l n)-    rn_field (L l fld, n') =-      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)-         ; return (L l (fld { hsRecFieldArg = arg' })) }--    loc = maybe noSrcSpan getLoc dd--    -- Get the arguments of the implicit binders-    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats-      where-        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)--    -- Don't warn for let P{..} = ... in ...-    check_unused_wildcard = case mk of-                              LetMk{} -> const (return ())-                              LamMk{} -> checkUnusedRecordWildcardCps loc--        -- Suppress unused-match reporting for fields introduced by ".."-    nested_mk Nothing  mk                    _  = mk-    nested_mk (Just _) mk@(LetMk {})         _  = mk-    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'-      = LamMk (report_unused && (n' <= n))--{--************************************************************************-*                                                                      *-        Record fields-*                                                                      *-************************************************************************--}--data HsRecFieldContext-  = HsRecFieldCon Name-  | HsRecFieldPat Name-  | HsRecFieldUpd--rnHsRecFields-    :: forall arg.-       HsRecFieldContext-    -> (SrcSpan -> RdrName -> arg)-         -- When punning, use this to build a new field-    -> HsRecFields GhcPs (Located arg)-    -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)---- This surprisingly complicated pass---   a) looks up the field name (possibly using disambiguation)---   b) fills in puns and dot-dot stuff--- When we've finished, we've renamed the LHS, but not the RHS,--- of each x=e binding------ This is used for record construction and pattern-matching, but not updates.--rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })-  = do { pun_ok      <- xoptM LangExt.RecordPuns-       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields-       ; let parent = guard disambig_ok >> mb_con-       ; flds1  <- mapM (rn_fld pun_ok parent) flds-       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds-       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1-       ; let all_flds | null dotdot_flds = flds1-                      | otherwise        = flds1 ++ dotdot_flds-       ; return (all_flds, mkFVs (getFieldIds all_flds)) }-  where-    mb_con = case ctxt of-                HsRecFieldCon con  -> Just con-                HsRecFieldPat con  -> Just con-                _ {- update -}     -> Nothing--    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)-           -> RnM (LHsRecField GhcRn (Located arg))-    rn_fld pun_ok parent (L l-                           (HsRecField-                              { hsRecFieldLbl =-                                  (L loc (FieldOcc _ (L ll lbl)))-                              , hsRecFieldArg = arg-                              , hsRecPun      = pun }))-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl-           ; arg' <- if pun-                     then do { checkErr pun_ok (badPun (L loc lbl))-                               -- Discard any module qualifier (#11662)-                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L loc (mk_arg loc arg_rdr)) }-                     else return arg-           ; return (L l (HsRecField-                             { hsRecFieldLbl = (L loc (FieldOcc-                                                          sel (L ll lbl)))-                             , hsRecFieldArg = arg'-                             , hsRecPun      = pun })) }-    rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))-      = panic "rnHsRecFields"---    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat-              -> Maybe Name -- The constructor (Nothing for an-                                --    out of scope constructor)-              -> [LHsRecField GhcRn (Located arg)] -- Explicit fields-              -> RnM ([LHsRecField GhcRn (Located arg)])   -- Field Labels we need to fill in-    rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match-      | not (isUnboundName con) -- This test is because if the constructor-                                -- isn't in scope the constructor lookup will add-                                -- an error but still return an unbound name. We-                                -- don't want that to screw up the dot-dot fill-in stuff.-      = ASSERT( flds `lengthIs` n )-        do { dd_flag <- xoptM LangExt.RecordWildCards-           ; checkErr dd_flag (needFlagDotDot ctxt)-           ; (rdr_env, lcl_env) <- getRdrEnvs-           ; con_fields <- lookupConstructorFields con-           ; when (null con_fields) (addErr (badDotDotCon con))-           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)--                   -- For constructor uses (but not patterns)-                   -- the arg should be in scope locally;-                   -- i.e. not top level or imported-                   -- Eg.  data R = R { x,y :: Int }-                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}-                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env--                 (dot_dot_fields, dot_dot_gres)-                        = unzip [ (fl, gre)-                                | fl <- con_fields-                                , let lbl = mkVarOccFS (flLabel fl)-                                , not (lbl `elemOccSet` present_flds)-                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]-                                              -- Check selector is in scope-                                , case ctxt of-                                    HsRecFieldCon {} -> arg_in_scope lbl-                                    _other           -> True ]--           ; addUsedGREs dot_dot_gres-           ; return [ L loc (HsRecField-                        { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))-                        , hsRecFieldArg = L loc (mk_arg loc arg_rdr)-                        , hsRecPun      = False })-                    | fl <- dot_dot_fields-                    , let sel     = flSelector fl-                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }--    rn_dotdot _dotdot _mb_con _flds-      = return []-      -- _dotdot = Nothing => No ".." at all-      -- _mb_con = Nothing => Record update-      -- _mb_con = Just unbound => Out of scope data constructor--    dup_flds :: [NE.NonEmpty RdrName]-        -- Each list represents a RdrName that occurred more than once-        -- (the list contains all occurrences)-        -- Each list in dup_fields is non-empty-    (_, dup_flds) = removeDups compare (getFieldLbls flds)----- NB: Consider this:---      module Foo where { data R = R { fld :: Int } }---      module Odd where { import Foo; fld x = x { fld = 3 } }--- Arguably this should work, because the reference to 'fld' is--- unambiguous because there is only one field id 'fld' in scope.--- But currently it's rejected.--rnHsRecUpdFields-    :: [LHsRecUpdField GhcPs]-    -> RnM ([LHsRecUpdField GhcRn], FreeVars)-rnHsRecUpdFields flds-  = do { pun_ok        <- xoptM LangExt.RecordPuns-       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields-       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds-       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds--       -- Check for an empty record update  e {}-       -- NB: don't complain about e { .. }, because rn_dotdot has done that already-       ; when (null flds) $ addErr emptyUpdateErr--       ; return (flds1, plusFVs fvss) }-  where-    doc = text "constructor field name"--    rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs-           -> RnM (LHsRecUpdField GhcRn, FreeVars)-    rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f-                                               , hsRecFieldArg = arg-                                               , hsRecPun      = pun }))-      = do { let lbl = rdrNameAmbiguousFieldOcc f-           ; sel <- setSrcSpan loc $-                      -- Defer renaming of overloaded fields to the typechecker-                      -- See Note [Disambiguating record fields] in TcExpr-                      if overload_ok-                          then do { mb <- lookupGlobalOccRn_overloaded-                                            overload_ok lbl-                                  ; case mb of-                                      Nothing ->-                                        do { addErr-                                               (unknownSubordinateErr doc lbl)-                                           ; return (Right []) }-                                      Just r  -> return r }-                          else fmap Left $ lookupGlobalOccRn lbl-           ; arg' <- if pun-                     then do { checkErr pun_ok (badPun (L loc lbl))-                               -- Discard any module qualifier (#11662)-                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L loc (HsVar noExtField (L loc arg_rdr))) }-                     else return arg-           ; (arg'', fvs) <- rnLExpr arg'--           ; let fvs' = case sel of-                          Left sel_name -> fvs `addOneFV` sel_name-                          Right [sel_name] -> fvs `addOneFV` sel_name-                          Right _       -> fvs-                 lbl' = case sel of-                          Left sel_name ->-                                     L loc (Unambiguous sel_name   (L loc lbl))-                          Right [sel_name] ->-                                     L loc (Unambiguous sel_name   (L loc lbl))-                          Right _ -> L loc (Ambiguous   noExtField (L loc lbl))--           ; return (L l (HsRecField { hsRecFieldLbl = lbl'-                                     , hsRecFieldArg = arg''-                                     , hsRecPun      = pun }), fvs') }--    dup_flds :: [NE.NonEmpty RdrName]-        -- Each list represents a RdrName that occurred more than once-        -- (the list contains all occurrences)-        -- Each list in dup_fields is non-empty-    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)----getFieldIds :: [LHsRecField GhcRn arg] -> [Name]-getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds--getFieldLbls :: [LHsRecField id arg] -> [RdrName]-getFieldLbls flds-  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds--getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]-getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds--needFlagDotDot :: HsRecFieldContext -> SDoc-needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,-                            text "Use RecordWildCards to permit this"]--badDotDotCon :: Name -> SDoc-badDotDotCon con-  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)-         , nest 2 (text "The constructor has no labelled fields") ]--emptyUpdateErr :: SDoc-emptyUpdateErr = text "Empty record update"--badPun :: Located RdrName -> SDoc-badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),-                   text "Use NamedFieldPuns to permit this"]--dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc-dupFieldErr ctxt dups-  = hsep [text "duplicate field name",-          quotes (ppr (NE.head dups)),-          text "in record", pprRFC ctxt]--pprRFC :: HsRecFieldContext -> SDoc-pprRFC (HsRecFieldCon {}) = text "construction"-pprRFC (HsRecFieldPat {}) = text "pattern"-pprRFC (HsRecFieldUpd {}) = text "update"--{--************************************************************************-*                                                                      *-\subsubsection{Literals}-*                                                                      *-************************************************************************--When literals occur we have to make sure-that the types and classes they involve-are made available.--}--rnLit :: HsLit p -> RnM ()-rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)-rnLit _ = return ()---- Turn a Fractional-looking literal which happens to be an integer into an--- Integer-looking literal.-generalizeOverLitVal :: OverLitVal -> OverLitVal-generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))-    | denominator val == 1 = HsIntegral (IL { il_text=src-                                            , il_neg=neg-                                            , il_value=numerator val})-generalizeOverLitVal lit = lit--isNegativeZeroOverLit :: HsOverLit t -> Bool-isNegativeZeroOverLit lit- = case ol_val lit of-        HsIntegral i   -> 0 == il_value i && il_neg i-        HsFractional f -> 0 == fl_value f && fl_neg f-        _              -> False--{--Note [Negative zero]-~~~~~~~~~~~~~~~~~~~~~~~~~-There were problems with negative zero in conjunction with Negative Literals-extension. Numeric literal value is contained in Integer and Rational types-inside IntegralLit and FractionalLit. These types cannot represent negative-zero value. So we had to add explicit field 'neg' which would hold information-about literal sign. Here in rnOverLit we use it to detect negative zeroes and-in this case return not only literal itself but also negateName so that users-can apply it explicitly. In this case it stays negative zero.  #13211--}--rnOverLit :: HsOverLit t ->-             RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)-rnOverLit origLit-  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals-        ; let { lit@(OverLit {ol_val=val})-            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}-            | otherwise       = origLit-          }-        ; let std_name = hsOverLitName val-        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)-            <- lookupSyntaxName std_name-        ; let rebindable = case from_thing_name of-                                HsVar _ lv -> (unLoc lv) /= std_name-                                _          -> panic "rnOverLit"-        ; let lit' = lit { ol_witness = from_thing_name-                         , ol_ext = rebindable }-        ; if isNegativeZeroOverLit lit'-          then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)-                      <- lookupSyntaxName negateName-                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)-                                  , fvs1 `plusFV` fvs2) }-          else return ((lit', Nothing), fvs1) }--{--************************************************************************-*                                                                      *-\subsubsection{Errors}-*                                                                      *-************************************************************************--}--patSigErr :: Outputable a => a -> SDoc-patSigErr ty-  =  (text "Illegal signature in pattern:" <+> ppr ty)-        $$ nest 4 (text "Use ScopedTypeVariables to permit it")--bogusCharError :: Char -> SDoc-bogusCharError c-  = text "character literal out of range: '\\" <> char c  <> char '\''--badViewPat :: Pat GhcPs -> SDoc-badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,-                       text "Use ViewPatterns to enable view patterns"]
− compiler/rename/RnSource.hs 
@@ -1,2415 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[RnSource]{Main pass of renamer}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module RnSource (-        rnSrcDecls, addTcgDUs, findSplice-    ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} RnExpr( rnLExpr )-import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )--import GHC.Hs-import FieldLabel-import RdrName-import RnTypes-import RnBinds-import RnEnv-import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames-                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV-                        , checkShadowedRdrNames, warnUnusedTypePatterns-                        , extendTyVarEnvFVRn, newLocalBndrsRn-                        , withHsDocContext )-import RnUnbound        ( mkUnboundName, notInScopeErr )-import RnNames-import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )-import TcAnnotations    ( annCtxt )-import TcRnMonad--import ForeignCall      ( CCallTarget(..) )-import Module-import HscTypes         ( Warnings(..), plusWarns )-import PrelNames        ( applicativeClassName, pureAName, thenAName-                        , monadClassName, returnMName, thenMName-                        , semigroupClassName, sappendName-                        , monoidClassName, mappendName-                        )-import Name-import NameSet-import NameEnv-import Avail-import Outputable-import Bag-import BasicTypes       ( pprRuleName, TypeOrKind(..) )-import FastString-import SrcLoc-import DynFlags-import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )-import HscTypes         ( HscEnv, hsc_dflags )-import ListSetOps       ( findDupsEq, removeDups, equivClasses )-import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)-                        , stronglyConnCompFromEdgedVerticesUniq )-import UniqSet-import OrdList-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Control.Arrow ( first )-import Data.List ( mapAccumL )-import qualified Data.List.NonEmpty as NE-import Data.List.NonEmpty ( NonEmpty(..) )-import Data.Maybe ( isNothing, fromMaybe, mapMaybe )-import qualified Data.Set as Set ( difference, fromList, toList, null )-import Data.Function ( on )--{- | @rnSourceDecl@ "renames" declarations.-It simultaneously performs dependency analysis and precedence parsing.-It also does the following error checks:--* Checks that tyvars are used properly. This includes checking-  for undefined tyvars, and tyvars in contexts that are ambiguous.-  (Some of this checking has now been moved to module @TcMonoType@,-  since we don't have functional dependency information at this point.)--* Checks that all variable occurrences are defined.--* Checks the @(..)@ etc constraints in the export list.--Brings the binders of the group into scope in the appropriate places;-does NOT assume that anything is in scope already--}-rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)--- Rename a top-level HsGroup; used for normal source files *and* hs-boot files-rnSrcDecls group@(HsGroup { hs_valds   = val_decls,-                            hs_splcds  = splice_decls,-                            hs_tyclds  = tycl_decls,-                            hs_derivds = deriv_decls,-                            hs_fixds   = fix_decls,-                            hs_warnds  = warn_decls,-                            hs_annds   = ann_decls,-                            hs_fords   = foreign_decls,-                            hs_defds   = default_decls,-                            hs_ruleds  = rule_decls,-                            hs_docs    = docs })- = do {-   -- (A) Process the fixity declarations, creating a mapping from-   --     FastStrings to FixItems.-   --     Also checks for duplicates.-   local_fix_env <- makeMiniFixityEnv fix_decls ;--   -- (B) Bring top level binders (and their fixities) into scope,-   --     *except* for the value bindings, which get done in step (D)-   --     with collectHsIdBinders. However *do* include-   ---   --        * Class ops, data constructors, and record fields,-   --          because they do not have value declarations.-   ---   --        * For hs-boot files, include the value signatures-   --          Again, they have no value declarations-   ---   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;---   setEnvs tc_envs $ do {--   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations--   -- (D1) Bring pattern synonyms into scope.-   --      Need to do this before (D2) because rnTopBindsLHS-   --      looks up those pattern synonyms (#9889)--   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {--   -- (D2) Rename the left-hand sides of the value bindings.-   --     This depends on everything from (B) being in scope.-   --     It uses the fixity env from (A) to bind fixities for view patterns.-   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;--   -- Bind the LHSes (and their fixities) in the global rdr environment-   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders-                                                    -- They are already in scope-   traceRn "rnSrcDecls" (ppr id_bndrs) ;-   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;-   setEnvs tc_envs $ do {--   --  Now everything is in scope, as the remaining renaming assumes.--   -- (E) Rename type and class decls-   --     (note that value LHSes need to be in scope for default methods)-   ---   -- You might think that we could build proper def/use information-   -- for type and class declarations, but they can be involved-   -- in mutual recursion across modules, and we only do the SCC-   -- analysis for them in the type checker.-   -- So we content ourselves with gathering uses only; that-   -- means we'll only report a declaration as unused if it isn't-   -- mentioned at all.  Ah well.-   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;-   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;--   -- (F) Rename Value declarations right-hand sides-   traceRn "Start rnmono" empty ;-   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;-   is_boot <- tcIsHsBootOrSig ;-   (rn_val_decls, bind_dus) <- if is_boot-    -- For an hs-boot, use tc_bndrs (which collects how we're renamed-    -- signatures), since val_bndr_set is empty (there are no x = ...-    -- bindings in an hs-boot.)-    then rnTopBindsBoot tc_bndrs new_lhs-    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;-   traceRn "finish rnmono" (ppr rn_val_decls) ;--   -- (G) Rename Fixity and deprecations--   -- Rename fixity declarations and error if we try to-   -- fix something from another module (duplicates were checked in (A))-   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;-   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))-                        fix_decls ;--   -- Rename deprec decls;-   -- check for duplicates and ensure that deprecated things are defined locally-   -- at the moment, we don't keep these around past renaming-   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;--   -- (H) Rename Everything else--   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $-                                   rnList rnHsRuleDecls rule_decls ;-                           -- Inside RULES, scoped type variables are on-   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;-   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;-   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;-   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;-   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;-      -- Haddock docs; no free vars-   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;--   last_tcg_env <- getGblEnv ;-   -- (I) Compute the results and return-   let {rn_group = HsGroup { hs_ext     = noExtField,-                             hs_valds   = rn_val_decls,-                             hs_splcds  = rn_splice_decls,-                             hs_tyclds  = rn_tycl_decls,-                             hs_derivds = rn_deriv_decls,-                             hs_fixds   = rn_fix_decls,-                             hs_warnds  = [], -- warns are returned in the tcg_env-                                             -- (see below) not in the HsGroup-                             hs_fords  = rn_foreign_decls,-                             hs_annds  = rn_ann_decls,-                             hs_defds  = rn_default_decls,-                             hs_ruleds = rn_rule_decls,-                             hs_docs   = rn_docs } ;--        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;-        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;-        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,-                              src_fvs5, src_fvs6, src_fvs7] ;-                -- It is tiresome to gather the binders from type and class decls--        src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ;-                -- Instance decls may have occurrences of things bound in bind_dus-                -- so we must put other_fvs last--        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)-                        in -- we return the deprecs in the env, not in the HsGroup above-                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };-       } ;-   traceRn "finish rnSrc" (ppr rn_group) ;-   traceRn "finish Dus" (ppr src_dus ) ;-   return (final_tcg_env, rn_group)-                    }}}}-rnSrcDecls (XHsGroup nec) = noExtCon nec--addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv--- This function could be defined lower down in the module hierarchy,--- but there doesn't seem anywhere very logical to put it.-addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }--rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)-rnList f xs = mapFvRn (wrapLocFstM f) xs--{--*********************************************************-*                                                       *-        HsDoc stuff-*                                                       *-*********************************************************--}--rnDocDecl :: DocDecl -> RnM DocDecl-rnDocDecl (DocCommentNext doc) = do-  rn_doc <- rnHsDoc doc-  return (DocCommentNext rn_doc)-rnDocDecl (DocCommentPrev doc) = do-  rn_doc <- rnHsDoc doc-  return (DocCommentPrev rn_doc)-rnDocDecl (DocCommentNamed str doc) = do-  rn_doc <- rnHsDoc doc-  return (DocCommentNamed str rn_doc)-rnDocDecl (DocGroup lev doc) = do-  rn_doc <- rnHsDoc doc-  return (DocGroup lev rn_doc)--{--*********************************************************-*                                                       *-        Source-code deprecations declarations-*                                                       *-*********************************************************--Check that the deprecated names are defined, are defined locally, and-that there are no duplicate deprecations.--It's only imported deprecations, dealt with in RnIfaces, that we-gather them together.--}---- checks that the deprecations are defined locally, and that there are no duplicates-rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings-rnSrcWarnDecls _ []-  = return NoWarnings--rnSrcWarnDecls bndr_set decls'-  = do { -- check for duplicates-       ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups-                          in addErrAt loc (dupWarnDecl lrdr' rdr))-               warn_rdr_dups-       ; pairs_s <- mapM (addLocM rn_deprec) decls-       ; return (WarnSome ((concat pairs_s))) }- where-   decls = concatMap (wd_warnings . unLoc) decls'--   sig_ctxt = TopSigCtxt bndr_set--   rn_deprec (Warning _ rdr_names txt)-       -- ensures that the names are defined locally-     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)-                                rdr_names-          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }-   rn_deprec (XWarnDecl nec) = noExtCon nec--   what = text "deprecation"--   warn_rdr_dups = findDupRdrNames-                   $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls--findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]-findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))---- look for duplicates among the OccNames;--- we check that the names are defined above--- invt: the lists returned by findDupsEq always have at least two elements--dupWarnDecl :: Located RdrName -> RdrName -> SDoc--- Located RdrName -> DeprecDecl RdrName -> SDoc-dupWarnDecl d rdr_name-  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),-          text "also at " <+> ppr (getLoc d)]--{--*********************************************************-*                                                      *-\subsection{Annotation declarations}-*                                                      *-*********************************************************--}--rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)-rnAnnDecl ann@(HsAnnotation _ s provenance expr)-  = addErrCtxt (annCtxt ann) $-    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance-       ; (expr', expr_fvs) <- setStage (Splice Untyped) $-                              rnLExpr expr-       ; return (HsAnnotation noExtField s provenance' expr',-                 provenance_fvs `plusFV` expr_fvs) }-rnAnnDecl (XAnnDecl nec) = noExtCon nec--rnAnnProvenance :: AnnProvenance RdrName-                -> RnM (AnnProvenance Name, FreeVars)-rnAnnProvenance provenance = do-    provenance' <- traverse lookupTopBndrRn provenance-    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))--{--*********************************************************-*                                                      *-\subsection{Default declarations}-*                                                      *-*********************************************************--}--rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)-rnDefaultDecl (DefaultDecl _ tys)-  = do { (tys', fvs) <- rnLHsTypes doc_str tys-       ; return (DefaultDecl noExtField tys', fvs) }-  where-    doc_str = DefaultDeclCtx-rnDefaultDecl (XDefaultDecl nec) = noExtCon nec--{--*********************************************************-*                                                      *-\subsection{Foreign declarations}-*                                                      *-*********************************************************--}--rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)-rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })-  = do { topEnv :: HscEnv <- getTopEnv-       ; name' <- lookupLocatedTopBndrRn name-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty--        -- Mark any PackageTarget style imports as coming from the current package-       ; let unitId = thisPackage $ hsc_dflags topEnv-             spec'      = patchForeignImport unitId spec--       ; return (ForeignImport { fd_i_ext = noExtField-                               , fd_name = name', fd_sig_ty = ty'-                               , fd_fi = spec' }, fvs) }--rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })-  = do { name' <- lookupLocatedOccRn name-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty-       ; return (ForeignExport { fd_e_ext = noExtField-                               , fd_name = name', fd_sig_ty = ty'-                               , fd_fe = spec }-                , fvs `addOneFV` unLoc name') }-        -- NB: a foreign export is an *occurrence site* for name, so-        --     we add it to the free-variable list.  It might, for example,-        --     be imported from another module--rnHsForeignDecl (XForeignDecl nec) = noExtCon nec---- | For Windows DLLs we need to know what packages imported symbols are from---      to generate correct calls. Imported symbols are tagged with the current---      package, so if they get inlined across a package boundary we'll still---      know where they're from.----patchForeignImport :: UnitId -> ForeignImport -> ForeignImport-patchForeignImport unitId (CImport cconv safety fs spec src)-        = CImport cconv safety fs (patchCImportSpec unitId spec) src--patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec-patchCImportSpec unitId spec- = case spec of-        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget-        _                       -> spec--patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget-patchCCallTarget unitId callTarget =-  case callTarget of-  StaticTarget src label Nothing isFun-                              -> StaticTarget src label (Just unitId) isFun-  _                           -> callTarget--{--*********************************************************-*                                                      *-\subsection{Instance declarations}-*                                                      *-*********************************************************--}--rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)-rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })-  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi-       ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }--rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })-  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi-       ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }--rnSrcInstDecl (ClsInstD { cid_inst = cid })-  = do { traceRn "rnSrcIstDecl {" (ppr cid)-       ; (cid', fvs) <- rnClsInstDecl cid-       ; traceRn "rnSrcIstDecl end }" empty-       ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) }--rnSrcInstDecl (XInstDecl nec) = noExtCon nec---- | Warn about non-canonical typeclass instance declarations------ A "non-canonical" instance definition can occur for instances of a--- class which redundantly defines an operation its superclass--- provides as well (c.f. `return`/`pure`). In such cases, a canonical--- instance is one where the subclass inherits its method--- implementation from its superclass instance (usually the subclass--- has a default method implementation to that effect). Consequently,--- a non-canonical instance occurs when this is not the case.------ See also descriptions of 'checkCanonicalMonadInstances' and--- 'checkCanonicalMonoidInstances'-checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()-checkCanonicalInstances cls poly_ty mbinds = do-    whenWOptM Opt_WarnNonCanonicalMonadInstances-        checkCanonicalMonadInstances--    whenWOptM Opt_WarnNonCanonicalMonoidInstances-        checkCanonicalMonoidInstances--  where-    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance-    -- declarations. Specifically, the following conditions are verified:-    ---    -- In 'Monad' instances declarations:-    ---    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)-    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)-    ---    -- In 'Applicative' instance declarations:-    ---    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).-    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).-    ---    checkCanonicalMonadInstances-      | cls == applicativeClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do-              case mbind of-                  FunBind { fun_id = L _ name-                          , fun_matches = mg }-                      | name == pureAName, isAliasMG mg == Just returnMName-                      -> addWarnNonCanonicalMethod1-                            Opt_WarnNonCanonicalMonadInstances "pure" "return"--                      | name == thenAName, isAliasMG mg == Just thenMName-                      -> addWarnNonCanonicalMethod1-                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"--                  _ -> return ()--      | cls == monadClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do-              case mbind of-                  FunBind { fun_id = L _ name-                          , fun_matches = mg }-                      | name == returnMName, isAliasMG mg /= Just pureAName-                      -> addWarnNonCanonicalMethod2-                            Opt_WarnNonCanonicalMonadInstances "return" "pure"--                      | name == thenMName, isAliasMG mg /= Just thenAName-                      -> addWarnNonCanonicalMethod2-                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"--                  _ -> return ()--      | otherwise = return ()--    -- | Check whether Monoid(mappend) is defined in terms of-    -- Semigroup((<>)) (and not the other way round). Specifically,-    -- the following conditions are verified:-    ---    -- In 'Monoid' instances declarations:-    ---    --  * If 'mappend' is overridden it must be canonical-    --    (i.e. @mappend = (<>)@)-    ---    -- In 'Semigroup' instance declarations:-    ---    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).-    ---    checkCanonicalMonoidInstances-      | cls == semigroupClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do-              case mbind of-                  FunBind { fun_id      = L _ name-                          , fun_matches = mg }-                      | name == sappendName, isAliasMG mg == Just mappendName-                      -> addWarnNonCanonicalMethod1-                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"--                  _ -> return ()--      | cls == monoidClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do-              case mbind of-                  FunBind { fun_id = L _ name-                          , fun_matches = mg }-                      | name == mappendName, isAliasMG mg /= Just sappendName-                      -> addWarnNonCanonicalMethod2NoDefault-                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"--                  _ -> return ()--      | otherwise = return ()--    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"-    -- binding, and return @Just rhsName@ if this is the case-    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name-    isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []-                                             , m_grhss = grhss })])}-        | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss-        , EmptyLocalBinds _ <- unLoc lbinds-        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)-    isAliasMG _ = Nothing--    -- got "lhs = rhs" but expected something different-    addWarnNonCanonicalMethod1 flag lhs rhs = do-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text (lhs ++ " = " ++ rhs)) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , text "Move definition from" <+>-                         quotes (text rhs) <+>-                         text "to" <+> quotes (text lhs)-                       ]--    -- expected "lhs = rhs" but got something else-    addWarnNonCanonicalMethod2 flag lhs rhs = do-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text lhs) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , text "Either remove definition for" <+>-                         quotes (text lhs) <+> text "or define as" <+>-                         quotes (text (lhs ++ " = " ++ rhs))-                       ]--    -- like above, but method has no default impl-    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text lhs) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , text "Define as" <+>-                         quotes (text (lhs ++ " = " ++ rhs))-                       ]--    -- stolen from TcInstDcls-    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc-    instDeclCtxt1 hs_inst_ty-      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))--    inst_decl_ctxt :: SDoc -> SDoc-    inst_decl_ctxt doc = hang (text "in the instance declaration for")-                         2 (quotes doc <> text ".")---rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)-rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds-                           , cid_sigs = uprags, cid_tyfam_insts = ats-                           , cid_overlap_mode = oflag-                           , cid_datafam_insts = adts })-  = do { (inst_ty', inst_fvs)-           <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty-       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'-       ; cls <--           case hsTyGetAppHead_maybe head_ty' of-             Just (L _ cls) -> pure cls-             Nothing -> do-               -- The instance is malformed. We'd still like-               -- to make *some* progress (rather than failing outright), so-               -- we report an error and continue for as long as we can.-               -- Importantly, this error should be thrown before we reach the-               -- typechecker, lest we encounter different errors that are-               -- hopelessly confusing (such as the one in #16114).-               addErrAt (getLoc (hsSigType inst_ty)) $-                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))-                    2 (vcat [ text "Class instances must be of the form"-                            , nest 2 $ text "context => C ty_1 ... ty_n"-                            , text "where" <+> quotes (char 'C')-                              <+> text "is a class"-                            ])-               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))--          -- Rename the bindings-          -- The typechecker (not the renamer) checks that all-          -- the bindings are for the right class-          -- (Slightly strangely) when scoped type variables are on, the-          -- forall-d tyvars scope over the method bindings too-       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags--       ; checkCanonicalInstances cls inst_ty' mbinds'--       -- Rename the associated types, and type signatures-       -- Both need to have the instance type variables in scope-       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)-       ; ((ats', adts'), more_fvs)-             <- extendTyVarEnvFVRn ktv_names $-                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats-                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts-                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }--       ; let all_fvs = meth_fvs `plusFV` more_fvs-                                `plusFV` inst_fvs-       ; return (ClsInstDecl { cid_ext = noExtField-                             , cid_poly_ty = inst_ty', cid_binds = mbinds'-                             , cid_sigs = uprags', cid_tyfam_insts = ats'-                             , cid_overlap_mode = oflag-                             , cid_datafam_insts = adts' },-                 all_fvs) }-             -- We return the renamed associated data type declarations so-             -- that they can be entered into the list of type declarations-             -- for the binding group, but we also keep a copy in the instance.-             -- The latter is needed for well-formedness checks in the type-             -- checker (eg, to ensure that all ATs of the instance actually-             -- receive a declaration).-             -- NB: Even the copies in the instance declaration carry copies of-             --     the instance context after renaming.  This is a bit-             --     strange, but should not matter (and it would be more work-             --     to remove the context).-rnClsInstDecl (XClsInstDecl nec) = noExtCon nec--rnFamInstEqn :: HsDocContext-             -> AssocTyFamInfo-             -> [Located RdrName]    -- Kind variables from the equation's RHS-             -> FamInstEqn GhcPs rhs-             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))-             -> RnM (FamInstEqn GhcRn rhs', FreeVars)-rnFamInstEqn doc atfi rhs_kvars-    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon-                               , feqn_bndrs  = mb_bndrs-                               , feqn_pats   = pats-                               , feqn_fixity = fixity-                               , feqn_rhs    = payload }}) rn_payload-  = do { let mb_cls = case atfi of-                        NonAssocTyFamEqn     -> Nothing-                        AssocTyFamDeflt cls  -> Just cls-                        AssocTyFamInst cls _ -> Just cls-       ; tycon'   <- lookupFamInstName mb_cls tycon-       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats-             -- Use the "...Dups" form because it's needed-             -- below to report unused binder on the LHS--         -- Implicitly bound variables, empty if we have an explicit 'forall' according-         -- to the "forall-or-nothing" rule.-       ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups-                      | otherwise = []-       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars--       ; let bndrs = fromMaybe [] mb_bndrs-             bnd_vars = map hsLTyVarLocName bndrs-             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars-             -- Make sure to filter out the kind variables that were explicitly-             -- bound in the type patterns.-       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars--         -- all names not bound in an explict forall-       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names--             -- All the free vars of the family patterns-             -- with a sensible binding location-       ; ((bndrs', pats', payload'), fvs)-              <- bindLocalNamesFV all_imp_var_names $-                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)-                                   Nothing bndrs $ \bndrs' ->-                 -- Note: If we pass mb_cls instead of Nothing here,-                 --  bindLHsTyVarBndrs will use class variables for any names-                 --  the user meant to bring in scope here. This is an explicit-                 --  forall, so we want fresh names, not class variables.-                 --  Thus: always pass Nothing-                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats-                    ; (payload', rhs_fvs) <- rn_payload doc payload--                       -- Report unused binders on the LHS-                       -- See Note [Unused type variables in family instances]-                    ; let groups :: [NonEmpty (Located RdrName)]-                          groups = equivClasses cmpLocated $-                                   pat_kity_vars_with_dups-                    ; nms_dups <- mapM (lookupOccRn . unLoc) $-                                     [ tv | (tv :| (_:_)) <- groups ]-                          -- Add to the used variables-                          --  a) any variables that appear *more than once* on the LHS-                          --     e.g.   F a Int a = Bool-                          --  b) for associated instances, the variables-                          --     of the instance decl.  See-                          --     Note [Unused type variables in family instances]-                    ; let nms_used = extendNameSetList rhs_fvs $-                                        inst_tvs ++ nms_dups-                          inst_tvs = case atfi of-                                       NonAssocTyFamEqn          -> []-                                       AssocTyFamDeflt _         -> []-                                       AssocTyFamInst _ inst_tvs -> inst_tvs-                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'-                    ; warnUnusedTypePatterns all_nms nms_used--                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }--       ; let all_fvs  = fvs `addOneFV` unLoc tycon'-            -- type instance => use, hence addOneFV--       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]-                      , hsib_body-                          = FamEqn { feqn_ext    = noExtField-                                   , feqn_tycon  = tycon'-                                   , feqn_bndrs  = bndrs' <$ mb_bndrs-                                   , feqn_pats   = pats'-                                   , feqn_fixity = fixity-                                   , feqn_rhs    = payload' } },-                 all_fvs) }-rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec-rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec--rnTyFamInstDecl :: AssocTyFamInfo-                -> TyFamInstDecl GhcPs-                -> RnM (TyFamInstDecl GhcRn, FreeVars)-rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })-  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn-       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }---- | Tracks whether we are renaming:------ 1. A type family equation that is not associated---    with a parent type class ('NonAssocTyFamEqn')------ 2. An associated type family default delcaration ('AssocTyFamDeflt')------ 3. An associated type family instance declaration ('AssocTyFamInst')-data AssocTyFamInfo-  = NonAssocTyFamEqn-  | AssocTyFamDeflt Name   -- Name of the parent class-  | AssocTyFamInst  Name   -- Name of the parent class-                    [Name] -- Names of the tyvars of the parent instance decl---- | Tracks whether we are renaming an equation in a closed type family--- equation ('ClosedTyFam') or not ('NotClosedTyFam').-data ClosedTyFamInfo-  = NotClosedTyFam-  | ClosedTyFam (Located RdrName) Name-                -- The names (RdrName and Name) of the closed type family--rnTyFamInstEqn :: AssocTyFamInfo-               -> ClosedTyFamInfo-               -> TyFamInstEqn GhcPs-               -> RnM (TyFamInstEqn GhcRn, FreeVars)-rnTyFamInstEqn atfi ctf_info-    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon-                                   , feqn_rhs   = rhs }})-  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs-       ; (eqn'@(HsIB { hsib_body =-                       FamEqn { feqn_tycon = L _ tycon' }}), fvs)-           <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn-       ; case ctf_info of-           NotClosedTyFam -> pure ()-           ClosedTyFam fam_rdr_name fam_name ->-             checkTc (fam_name == tycon') $-             withHsDocContext (TyFamilyCtx fam_rdr_name) $-             wrongTyFamName fam_name tycon'-       ; pure (eqn', fvs) }-rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec-rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec--rnTyFamDefltDecl :: Name-                 -> TyFamDefltDecl GhcPs-                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)-rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)--rnDataFamInstDecl :: AssocTyFamInfo-                  -> DataFamInstDecl GhcPs-                  -> RnM (DataFamInstDecl GhcRn, FreeVars)-rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =-                         FamEqn { feqn_tycon = tycon-                                , feqn_rhs   = rhs }})})-  = do { let rhs_kvs = extractDataDefnKindVars rhs-       ; (eqn', fvs) <--           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn-       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }-rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))-  = noExtCon nec-rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec))-  = noExtCon nec---- Renaming of the associated types in instances.---- Rename associated type family decl in class-rnATDecls :: Name      -- Class-          -> [LFamilyDecl GhcPs]-          -> RnM ([LFamilyDecl GhcRn], FreeVars)-rnATDecls cls at_decls-  = rnList (rnFamDecl (Just cls)) at_decls--rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames-                  decl GhcPs ->               -- an instance. rnTyFamInstDecl-                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl-              -> Name      -- Class-              -> [Name]-              -> [Located (decl GhcPs)]-              -> RnM ([Located (decl GhcRn)], FreeVars)--- Used for data and type family defaults in a class decl--- and the family instance declarations in an instance------ NB: We allow duplicate associated-type decls;---     See Note [Associated type instances] in TcInstDcls-rnATInstDecls rnFun cls tv_ns at_insts-  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts-    -- See Note [Renaming associated types]--{- Note [Wildcards in family instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Wild cards can be used in type/data family instance declarations to indicate-that the name of a type variable doesn't matter. Each wild card will be-replaced with a new unique type variable. For instance:--    type family F a b :: *-    type instance F Int _ = Int--is the same as--    type family F a b :: *-    type instance F Int b = Int--This is implemented as follows: Unnamed wildcards remain unchanged after-the renamer, and then given fresh meta-variables during typechecking, and-it is handled pretty much the same way as the ones in partial type signatures.-We however don't want to emit hole constraints on wildcards in family-instances, so we turn on PartialTypeSignatures and turn off warning flag to-let typechecker know this.-See related Note [Wildcards in visible kind application] in TcHsType.hs--Note [Unused type variables in family instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the flag -fwarn-unused-type-patterns is on, the compiler reports-warnings about unused type variables in type-family instances. A-tpye variable is considered used (i.e. cannot be turned into a wildcard)-when-- * it occurs on the RHS of the family instance-   e.g.   type instance F a b = a    -- a is used on the RHS-- * it occurs multiple times in the patterns on the LHS-   e.g.   type instance F a a = Int  -- a appears more than once on LHS-- * it is one of the instance-decl variables, for associated types-   e.g.   instance C (a,b) where-            type T (a,b) = a-   Here the type pattern in the type instance must be the same as that-   for the class instance, so-            type T (a,_) = a-   would be rejected.  So we should not complain about an unused variable b--As usual, the warnings are not reported for type variables with names-beginning with an underscore.--Extra-constraints wild cards are not supported in type/data family-instance declarations.--Relevant tickets: #3699, #10586, #10982 and #11451.--Note [Renaming associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Check that the RHS of the decl mentions only type variables that are explicitly-bound on the LHS.  For example, this is not ok-   class C a b where-      type F a x :: *-   instance C (p,q) r where-      type F (p,q) x = (x, r)   -- BAD: mentions 'r'-c.f. #5515--Kind variables, on the other hand, are allowed to be implicitly or explicitly-bound. As examples, this (#9574) is acceptable:-   class Funct f where-      type Codomain f :: *-   instance Funct ('KProxy :: KProxy o) where-      -- o is implicitly bound by the kind signature-      -- of the LHS type pattern ('KProxy)-      type Codomain 'KProxy = NatTr (Proxy :: o -> *)-And this (#14131) is also acceptable:-    data family Nat :: k -> k -> *-    -- k is implicitly bound by an invisible kind pattern-    newtype instance Nat :: (k -> *) -> (k -> *) -> * where-      Nat :: (forall xx. f xx -> g xx) -> Nat f g-We could choose to disallow this, but then associated type families would not-be able to be as expressive as top-level type synonyms. For example, this type-synonym definition is allowed:-    type T = (Nothing :: Maybe a)-So for parity with type synonyms, we also allow:-    type family   T :: Maybe a-    type instance T = (Nothing :: Maybe a)--All this applies only for *instance* declarations.  In *class*-declarations there is no RHS to worry about, and the class variables-can all be in scope (#5862):-    class Category (x :: k -> k -> *) where-      type Ob x :: k -> Constraint-      id :: Ob x a => x a a-      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c-Here 'k' is in scope in the kind signature, just like 'x'.--Although type family equations can bind type variables with explicit foralls,-it need not be the case that all variables that appear on the RHS must be bound-by a forall. For instance, the following is acceptable:--   class C a where-     type T a b-   instance C (Maybe a) where-     type forall b. T (Maybe a) b = Either a b--Even though `a` is not bound by the forall, this is still accepted because `a`-was previously bound by the `instance C (Maybe a)` part. (see #16116).--In each case, the function which detects improperly bound variables on the RHS-is TcValidity.checkValidFamPats.--}---{--*********************************************************-*                                                      *-\subsection{Stand-alone deriving declarations}-*                                                      *-*********************************************************--}--rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)-rnSrcDerivDecl (DerivDecl _ ty mds overlap)-  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving-       ; unless standalone_deriv_ok (addErr standaloneDerivErr)-       ; (mds', ty', fvs)-           <- rnLDerivStrategy DerivDeclCtx mds $-              rnHsSigWcType BindUnlessForall DerivDeclCtx ty-       ; warnNoDerivStrat mds' loc-       ; return (DerivDecl noExtField ty' mds' overlap, fvs) }-  where-    loc = getLoc $ hsib_body $ hswc_body ty-rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec--standaloneDerivErr :: SDoc-standaloneDerivErr-  = hang (text "Illegal standalone deriving declaration")-       2 (text "Use StandaloneDeriving to enable this extension")--{--*********************************************************-*                                                      *-\subsection{Rules}-*                                                      *-*********************************************************--}--rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)-rnHsRuleDecls (HsRules { rds_src = src-                       , rds_rules = rules })-  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules-       ; return (HsRules { rds_ext = noExtField-                         , rds_src = src-                         , rds_rules = rn_rules }, fvs) }-rnHsRuleDecls (XRuleDecls nec) = noExtCon nec--rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)-rnHsRuleDecl (HsRule { rd_name = rule_name-                     , rd_act  = act-                     , rd_tyvs = tyvs-                     , rd_tmvs = tmvs-                     , rd_lhs  = lhs-                     , rd_rhs  = rhs })-  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs-       ; checkDupRdrNames rdr_names_w_loc-       ; checkShadowedRdrNames rdr_names_w_loc-       ; names <- newLocalBndrsRn rdr_names_w_loc-       ; let doc = RuleCtx (snd $ unLoc rule_name)-       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->-         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->-    do { (lhs', fv_lhs') <- rnLExpr lhs-       ; (rhs', fv_rhs') <- rnLExpr rhs-       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'-       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'-                        , rd_name = rule_name-                        , rd_act  = act-                        , rd_tyvs = tyvs'-                        , rd_tmvs = tmvs'-                        , rd_lhs  = lhs'-                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }-  where-    get_var (RuleBndrSig _ v _) = v-    get_var (RuleBndr _ v)      = v-    get_var (XRuleBndr nec)     = noExtCon nec-    in_rule = text "in the rule" <+> pprFullRuleName rule_name-rnHsRuleDecl (XRuleDecl nec) = noExtCon nec--bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs-               -> [LRuleBndr GhcPs] -> [Name]-               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))-               -> RnM (a, FreeVars)-bindRuleTmVars doc tyvs vars names thing_inside-  = go vars names $ \ vars' ->-    bindLocalNamesFV names (thing_inside vars')-  where-    go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside-      = go vars ns $ \ vars' ->-        thing_inside (L l (RuleBndr noExtField (L loc n)) : vars')--    go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)-       (n : ns) thing_inside-      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->-        go vars ns $ \ vars' ->-        thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars')--    go [] [] thing_inside = thing_inside []-    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)--    bind_free_tvs = case tyvs of Nothing -> AlwaysBind-                                 Just _  -> NeverBind--bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]-               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))-               -> RnM (b, FreeVars)-bindRuleTyVars doc in_doc (Just bndrs) thing_inside-  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)-bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing--{--Note [Rule LHS validity checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Check the shape of a transformation rule LHS.  Currently we only allow-LHSs of the form @(f e1 .. en)@, where @f@ is not one of the-@forall@'d variables.--We used restrict the form of the 'ei' to prevent you writing rules-with LHSs with a complicated desugaring (and hence unlikely to match);-(e.g. a case expression is not allowed: too elaborate.)--But there are legitimate non-trivial args ei, like sections and-lambdas.  So it seems simmpler not to check at all, and that is why-check_e is commented out.--}--checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()-checkValidRule rule_name ids lhs' fv_lhs'-  = do  {       -- Check for the form of the LHS-          case (validRuleLhs ids lhs') of-                Nothing  -> return ()-                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)--                -- Check that LHS vars are all bound-        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]-        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }--validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)--- Nothing => OK--- Just e  => Not ok, and e is the offending sub-expression-validRuleLhs foralls lhs-  = checkl lhs-  where-    checkl = check . unLoc--    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1-                                                      `mplus` checkl_e e2-    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2-    check (HsAppType _ e _)               = checkl e-    check (HsVar _ lv)-      | (unLoc lv) `notElem` foralls      = Nothing-    check other                           = Just other  -- Failure--        -- Check an argument-    checkl_e _ = Nothing-    -- Was (check_e e); see Note [Rule LHS validity checking]--{-      Commented out; see Note [Rule LHS validity checking] above-    check_e (HsVar v)     = Nothing-    check_e (HsPar e)     = checkl_e e-    check_e (HsLit e)     = Nothing-    check_e (HsOverLit e) = Nothing--    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2-    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2-    check_e (NegApp e _)         = checkl_e e-    check_e (ExplicitList _ es)  = checkl_es es-    check_e other                = Just other   -- Fails--    checkl_es es = foldr (mplus . checkl_e) Nothing es--}--badRuleVar :: FastString -> Name -> SDoc-badRuleVar name var-  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,-         text "Forall'd variable" <+> quotes (ppr var) <+>-                text "does not appear on left hand side"]--badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc-badRuleLhsErr name lhs bad_e-  = sep [text "Rule" <+> pprRuleName name <> colon,-         nest 2 (vcat [err,-                       text "in left-hand side:" <+> ppr lhs])]-    $$-    text "LHS must be of form (f e1 .. en) where f is not forall'd"-  where-    err = case bad_e of-            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv)-            _                 -> text "Illegal expression:" <+> ppr bad_e--{- **************************************************************-         *                                                      *-      Renaming type, class, instance and role declarations-*                                                               *-*****************************************************************--@rnTyDecl@ uses the `global name function' to create a new type-declaration in which local names have been replaced by their original-names, reporting any unknown names.--Renaming type variables is a pain. Because they now contain uniques,-it is necessary to pass in an association list which maps a parsed-tyvar to its @Name@ representation.-In some cases (type signatures of values),-it is even necessary to go over the type first-in order to get the set of tyvars used by it, make an assoc list,-and then go over it again to rename the tyvars!-However, we can also do some scoping checks at the same time.--Note [Dependency analysis of type, class, and instance decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A TyClGroup represents a strongly connected components of-type/class/instance decls, together with the role annotations for the-type/class declarations.  The renamer uses strongly connected-comoponent analysis to build these groups.  We do this for a number of-reasons:--* Improve kind error messages. Consider--     data T f a = MkT f a-     data S f a = MkS f (T f a)--  This has a kind error, but the error message is better if you-  check T first, (fixing its kind) and *then* S.  If you do kind-  inference together, you might get an error reported in S, which-  is jolly confusing.  See #4875---* Increase kind polymorphism.  See TcTyClsDecls-  Note [Grouping of type and class declarations]--Why do the instance declarations participate?  At least two reasons--* Consider (#11348)--     type family F a-     type instance F Int = Bool--     data R = MkR (F Int)--     type Foo = 'MkR 'True--  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't-  know that unless we've looked at the type instance declaration for F-  before kind-checking Foo.--* Another example is this (#3990).--     data family Complex a-     data instance Complex Double = CD {-# UNPACK #-} !Double-                                       {-# UNPACK #-} !Double--     data T = T {-# UNPACK #-} !(Complex Double)--  Here, to generate the right kind of unpacked implementation for T,-  we must have access to the 'data instance' declaration.--* Things become more complicated when we introduce transitive-  dependencies through imported definitions, like in this scenario:--      A.hs-        type family Closed (t :: Type) :: Type where-          Closed t = Open t--        type family Open (t :: Type) :: Type--      B.hs-        data Q where-          Q :: Closed Bool -> Q--        type instance Open Int = Bool--        type S = 'Q 'True--  Somehow, we must ensure that the instance Open Int = Bool is checked before-  the type synonym S. While we know that S depends upon 'Q depends upon Closed,-  we have no idea that Closed depends upon Open!--  To accommodate for these situations, we ensure that an instance is checked-  before every @TyClDecl@ on which it does not depend. That's to say, instances-  are checked as early as possible in @tcTyAndClassDecls@.---------------------------------------So much for WHY.  What about HOW?  It's pretty easy:--(1) Rename the type/class, instance, and role declarations-    individually--(2) Do strongly-connected component analysis of the type/class decls,-    We'll make a TyClGroup for each SCC--    In this step we treat a reference to a (promoted) data constructor-    K as a dependency on its parent type.  Thus-        data T = K1 | K2-        data S = MkS (Proxy 'K1)-    Here S depends on 'K1 and hence on its parent T.--    In this step we ignore instances; see-    Note [No dependencies on data instances]--(3) Attach roles to the appropriate SCC--(4) Attach instances to the appropriate SCC.-    We add an instance decl to SCC when:-      all its free types/classes are bound in this SCC or earlier ones--(5) We make an initial TyClGroup, with empty group_tyclds, for any-    (orphan) instances that affect only imported types/classes--Steps (3) and (4) are done by the (mapAccumL mk_group) call.--Note [No dependencies on data instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   data family D a-   data instance D Int = D1-   data S = MkS (Proxy 'D1)--Here the declaration of S depends on the /data instance/ declaration-for 'D Int'.  That makes things a lot more complicated, especially-if the data instance is an associated type of an enclosing class instance.-(And the class instance might have several associated type instances-with different dependency structure!)--Ugh.  For now we simply don't allow promotion of data constructors for-data instances.  See Note [AFamDataCon: not promoting data family-constructors] in TcEnv--}---rnTyClDecls :: [TyClGroup GhcPs]-            -> RnM ([TyClGroup GhcRn], FreeVars)--- Rename the declarations and do dependency analysis on them-rnTyClDecls tycl_ds-  = do { -- Rename the type/class, instance, and role declaraations-       ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)-       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)-       ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)-       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)-       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)--       -- Do SCC analysis on the type/class decls-       ; rdr_env <- getGlobalRdrEnv-       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs-             role_annot_env = mkRoleAnnotEnv role_annots-             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs--             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs-             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map--             first_group-               | null init_inst_ds = []-               | otherwise = [TyClGroup { group_ext    = noExtField-                                        , group_tyclds = []-                                        , group_kisigs = []-                                        , group_roles  = []-                                        , group_instds = init_inst_ds }]--             (final_inst_ds, groups)-                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs--             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`-                       foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`-                       foldr (plusFV . snd) emptyFVs kisigs_w_fvs--             all_groups = first_group ++ groups--       ; MASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map-                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )--       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)-       ; return (all_groups, all_fvs) }-  where-    mk_group :: RoleAnnotEnv-             -> KindSigEnv-             -> InstDeclFreeVarsMap-             -> SCC (LTyClDecl GhcRn)-             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)-    mk_group role_env kisig_env inst_map scc-      = (inst_map', group)-      where-        tycl_ds              = flattenSCC scc-        bndrs                = map (tcdName . unLoc) tycl_ds-        roles                = getRoleAnnots bndrs role_env-        kisigs               = getKindSigs   bndrs kisig_env-        (inst_ds, inst_map') = getInsts      bndrs inst_map-        group = TyClGroup { group_ext    = noExtField-                          , group_tyclds = tycl_ds-                          , group_kisigs = kisigs-                          , group_roles  = roles-                          , group_instds = inst_ds }---- | Free variables of standalone kind signatures.-newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)--lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars-lookupKindSig_FV_Env (KindSig_FV_Env e) name-  = fromMaybe emptyFVs (lookupNameEnv e name)---- | Standalone kind signatures.-type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)--mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)-mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)-  where-    kisig_env = mapNameEnv fst compound_env-    kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)-    compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)-      = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs--getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]-getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs--rnStandaloneKindSignatures-  :: NameSet  -- names of types and classes in the current TyClGroup-  -> [LStandaloneKindSig GhcPs]-  -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]-rnStandaloneKindSignatures tc_names kisigs-  = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs-             get_name = standaloneKindSigName . unLoc-       ; mapM_ dupKindSig_Err dup_kisigs-       ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups-       }--rnStandaloneKindSignature-  :: NameSet  -- names of types and classes in the current TyClGroup-  -> StandaloneKindSig GhcPs-  -> RnM (StandaloneKindSig GhcRn, FreeVars)-rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)-  = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures-        ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr-        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v-        ; let doc = StandaloneKindSigCtx (ppr v)-        ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki-        ; return (StandaloneKindSig noExtField new_v new_ki, fvs)-        }-  where-    standaloneKiSigErr :: SDoc-    standaloneKiSigErr =-      hang (text "Illegal standalone kind signature")-         2 (text "Did you mean to enable StandaloneKindSignatures?")-rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec--depAnalTyClDecls :: GlobalRdrEnv-                 -> KindSig_FV_Env-                 -> [(LTyClDecl GhcRn, FreeVars)]-                 -> [SCC (LTyClDecl GhcRn)]--- See Note [Dependency analysis of type, class, and instance decls]-depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs-  = stronglyConnCompFromEdgedVerticesUniq edges-  where-    edges :: [ Node Name (LTyClDecl GhcRn) ]-    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))-            | (d, fvs) <- ds_w_fvs,-              let { name = tcdName (unLoc d)-                  ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name-                  ; deps = fvs `plusFV` kisig_fvs-                  }-            ]-            -- It's OK to use nonDetEltsUFM here as-            -- stronglyConnCompFromEdgedVertices is still deterministic-            -- even if the edges are in nondeterministic order as explained-            -- in Note [Deterministic SCC] in Digraph.--toParents :: GlobalRdrEnv -> NameSet -> NameSet-toParents rdr_env ns-  = nonDetFoldUniqSet add emptyNameSet ns-  -- It's OK to use nonDetFoldUFM because we immediately forget the-  -- ordering by creating a set-  where-    add n s = extendNameSet s (getParent rdr_env n)--getParent :: GlobalRdrEnv -> Name -> Name-getParent rdr_env n-  = case lookupGRE_Name rdr_env n of-      Just gre -> case gre_par gre of-                    ParentIs  { par_is = p } -> p-                    FldParent { par_is = p } -> p-                    _                        -> n-      Nothing -> n---{- ******************************************************-*                                                       *-       Role annotations-*                                                       *-****************************************************** -}---- | Renames role annotations, returning them as the values in a NameEnv--- and checks for duplicate role annotations.--- It is quite convenient to do both of these in the same place.--- See also Note [Role annotations in the renamer]-rnRoleAnnots :: NameSet-             -> [LRoleAnnotDecl GhcPs]-             -> RnM [LRoleAnnotDecl GhcRn]-rnRoleAnnots tc_names role_annots-  = do {  -- Check for duplicates *before* renaming, to avoid-          -- lumping together all the unboundNames-         let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots-             get_name = roleAnnotDeclName . unLoc-       ; mapM_ dupRoleAnnotErr dup_annots-       ; mapM (wrapLocM rn_role_annot1) no_dups }-  where-    rn_role_annot1 (RoleAnnotDecl _ tycon roles)-      = do {  -- the name is an *occurrence*, but look it up only in the-              -- decls defined in this group (see #10263)-             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)-                                          (text "role annotation")-                                          tycon-           ; return $ RoleAnnotDecl noExtField tycon' roles }-    rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec--dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()-dupRoleAnnotErr list-  = addErrAt loc $-    hang (text "Duplicate role annotations for" <+>-          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)-       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)-    where-      sorted_list = NE.sortBy cmp_annot list-      ((L loc first_decl) :| _) = sorted_list--      pp_role_annot (L loc decl) = hang (ppr decl)-                                      4 (text "-- written at" <+> ppr loc)--      cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2--dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()-dupKindSig_Err list-  = addErrAt loc $-    hang (text "Duplicate standalone kind signatures for" <+>-          quotes (ppr $ standaloneKindSigName first_decl) <> colon)-       2 (vcat $ map pp_kisig $ NE.toList sorted_list)-    where-      sorted_list = NE.sortBy cmp_loc list-      ((L loc first_decl) :| _) = sorted_list--      pp_kisig (L loc decl) =-        hang (ppr decl) 4 (text "-- written at" <+> ppr loc)--      cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2--{- Note [Role annotations in the renamer]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must ensure that a type's role annotation is put in the same group as the-proper type declaration. This is because role annotations are needed during-type-checking when creating the type's TyCon. So, rnRoleAnnots builds a-NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that-type, if any. Then, this map can be used to add the role annotations to the-groups after dependency analysis.--This process checks for duplicate role annotations, where we must be careful-to do the check *before* renaming to avoid calling all unbound names duplicates-of one another.--The renaming process, as usual, might identify and report errors for unbound-names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using-lookupGlobalOccRn led to #8485).--}---{- ******************************************************-*                                                       *-       Dependency info for instances-*                                                       *-****************************************************** -}--------------------------------------------------------------- | 'InstDeclFreeVarsMap is an association of an---   @InstDecl@ with @FreeVars@. The @FreeVars@ are---   the tycon names that are both---     a) free in the instance declaration---     b) bound by this group of type/class/instance decls-type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]---- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the---   @FreeVars@ which are *not* the binders of a @TyClDecl@.-mkInstDeclFreeVarsMap :: GlobalRdrEnv-                      -> NameSet-                      -> [(LInstDecl GhcRn, FreeVars)]-                      -> InstDeclFreeVarsMap-mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs-  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)-    | (inst_decl, fvs) <- inst_ds_fvs ]---- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the---   @InstDeclFreeVarsMap@ with these entries removed.--- We call (getInsts tcs instd_map) when we've completed the declarations--- for 'tcs'.  The call returns (inst_decls, instd_map'), where---   inst_decls are the instance declarations all of---              whose free vars are now defined---   instd_map' is the inst-decl map with 'tcs' removed from---               the free-var set-getInsts :: [Name] -> InstDeclFreeVarsMap-         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)-getInsts bndrs inst_decl_map-  = partitionWith pick_me inst_decl_map-  where-    pick_me :: (LInstDecl GhcRn, FreeVars)-            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)-    pick_me (decl, fvs)-      | isEmptyNameSet depleted_fvs = Left decl-      | otherwise                   = Right (decl, depleted_fvs)-      where-        depleted_fvs = delFVs bndrs fvs--{- ******************************************************-*                                                       *-         Renaming a type or class declaration-*                                                       *-****************************************************** -}--rnTyClDecl :: TyClDecl GhcPs-           -> RnM (TyClDecl GhcRn, FreeVars)---- All flavours of top-level type family declarations ("type family", "newtype--- family", and "data family")-rnTyClDecl (FamDecl { tcdFam = fam })-  = do { (fam', fvs) <- rnFamDecl Nothing fam-       ; return (FamDecl noExtField fam', fvs) }--rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,-                      tcdFixity = fixity, tcdRhs = rhs })-  = do { tycon' <- lookupLocatedTopBndrRn tycon-       ; let kvs = extractHsTyRdrTyVarsKindVars rhs-             doc = TySynCtx tycon-       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)-       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->-    do { (rhs', fvs) <- rnTySyn doc rhs-       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'-                         , tcdFixity = fixity-                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }---- "data", "newtype" declarations-rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec-rnTyClDecl (DataDecl-    { tcdLName = tycon, tcdTyVars = tyvars,-      tcdFixity = fixity,-      tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data-                                   , dd_kindSig = kind_sig} })-  = do { tycon' <- lookupLocatedTopBndrRn tycon-       ; let kvs = extractDataDefnKindVars defn-             doc = TyDataCtx tycon-       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)-       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->-    do { (defn', fvs) <- rnDataDefn doc defn-       ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig-       ; let rn_info = DataDeclRn { tcdDataCusk = cusk-                                  , tcdFVs      = fvs }-       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)-       ; return (DataDecl { tcdLName    = tycon'-                          , tcdTyVars   = tyvars'-                          , tcdFixity   = fixity-                          , tcdDataDefn = defn'-                          , tcdDExt     = rn_info }, fvs) } }--rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,-                        tcdTyVars = tyvars, tcdFixity = fixity,-                        tcdFDs = fds, tcdSigs = sigs,-                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,-                        tcdDocs = docs})-  = do  { lcls' <- lookupLocatedTopBndrRn lcls-        ; let cls' = unLoc lcls'-              kvs = []  -- No scoped kind vars except those in-                        -- kind signatures on the tyvars--        -- Tyvars scope over superclass context and method signatures-        ; ((tyvars', context', fds', ats'), stuff_fvs)-            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do-                  -- Checks for distinct tyvars-             { (context', cxt_fvs) <- rnContext cls_doc context-             ; fds'  <- rnFds fds-                         -- The fundeps have no free variables-             ; (ats', fv_ats) <- rnATDecls cls' ats-             ; let fvs = cxt_fvs     `plusFV`-                         fv_ats-             ; return ((tyvars', context', fds', ats'), fvs) }--        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs--        -- No need to check for duplicate associated type decls-        -- since that is done by RnNames.extendGlobalRdrEnvRn--        -- Check the signatures-        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).-        ; let sig_rdr_names_w_locs =-                [op | L _ (ClassOpSig _ False ops _) <- sigs-                    , op <- ops]-        ; checkDupRdrNames sig_rdr_names_w_locs-                -- Typechecker is responsible for checking that we only-                -- give default-method bindings for things in this class.-                -- The renamer *could* check this for class decls, but can't-                -- for instance decls.--        -- The newLocals call is tiresome: given a generic class decl-        --      class C a where-        --        op :: a -> a-        --        op {| x+y |} (Inl a) = ...-        --        op {| x+y |} (Inr b) = ...-        --        op {| a*b |} (a*b)   = ...-        -- we want to name both "x" tyvars with the same unique, so that they are-        -- easy to group together in the typechecker.-        ; (mbinds', sigs', meth_fvs)-            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs-                -- No need to check for duplicate method signatures-                -- since that is done by RnNames.extendGlobalRdrEnvRn-                -- and the methods are already in scope--  -- Haddock docs-        ; docs' <- mapM (wrapLocM rnDocDecl) docs--        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs-        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',-                              tcdTyVars = tyvars', tcdFixity = fixity,-                              tcdFDs = fds', tcdSigs = sigs',-                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',-                              tcdDocs = docs', tcdCExt = all_fvs },-                  all_fvs ) }-  where-    cls_doc  = ClassDeclCtx lcls--rnTyClDecl (XTyClDecl nec) = noExtCon nec---- Does the data type declaration include a CUSK?-data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool-data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do-  { -- See Note [Unlifted Newtypes and CUSKs], and for a broader-    -- picture, see Note [Implementation of UnliftedNewtypes].-  ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes-  ; let non_cusk_newtype-          | NewType <- new_or_data =-              unlifted_newtypes && isNothing kind_sig-          | otherwise = False-    -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls-  ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype-  }--{- Note [Unlifted Newtypes and CUSKs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When unlifted newtypes are enabled, a newtype must have a kind signature-in order to be considered have a CUSK. This is because the flow of-kind inference works differently. Consider:--  newtype Foo = FooC Int--When UnliftedNewtypes is disabled, we decide that Foo has kind-`TYPE 'LiftedRep` without looking inside the data constructor. So, we-can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,-we fill in the kind of Foo as a metavar that gets solved by unification-with the kind of the field inside FooC (that is, Int, whose kind is-`TYPE 'LiftedRep`). But since we have to look inside the data constructors-to figure out the kind signature of Foo, it does not have a CUSK.--See Note [Implementation of UnliftedNewtypes] for where this fits in to-the broader picture of UnliftedNewtypes.--}---- "type" and "type instance" declarations-rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)-rnTySyn doc rhs = rnLHsType doc rhs--rnDataDefn :: HsDocContext -> HsDataDefn GhcPs-           -> RnM (HsDataDefn GhcRn, FreeVars)-rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType-                           , dd_ctxt = context, dd_cons = condecls-                           , dd_kindSig = m_sig, dd_derivs = derivs })-  = do  { checkTc (h98_style || null (unLoc context))-                  (badGadtStupidTheta doc)--        ; (m_sig', sig_fvs) <- case m_sig of-             Just sig -> first Just <$> rnLHsKind doc sig-             Nothing  -> return (Nothing, emptyFVs)-        ; (context', fvs1) <- rnContext doc context-        ; (derivs',  fvs3) <- rn_derivs derivs--        -- For the constructor declarations, drop the LocalRdrEnv-        -- in the GADT case, where the type variables in the declaration-        -- do not scope over the constructor signatures-        -- data T a where { T1 :: forall b. b-> b }-        ; let { zap_lcl_env | h98_style = \ thing -> thing-                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }-        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls-           -- No need to check for duplicate constructor decls-           -- since that is done by RnNames.extendGlobalRdrEnvRn--        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`-                        con_fvs `plusFV` sig_fvs-        ; return ( HsDataDefn { dd_ext = noExtField-                              , dd_ND = new_or_data, dd_cType = cType-                              , dd_ctxt = context', dd_kindSig = m_sig'-                              , dd_cons = condecls'-                              , dd_derivs = derivs' }-                 , all_fvs )-        }-  where-    h98_style = case condecls of  -- Note [Stupid theta]-                     (L _ (ConDeclGADT {})) : _  -> False-                     _                           -> True--    rn_derivs (L loc ds)-      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies-           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)-               multipleDerivClausesErr-           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds-           ; return (L loc ds', fvs) }-rnDataDefn _ (XHsDataDefn nec) = noExtCon nec--warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)-                 -> SrcSpan-                 -> RnM ()-warnNoDerivStrat mds loc-  = do { dyn_flags <- getDynFlags-       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $-           case mds of-             Nothing -> addWarnAt-               (Reason Opt_WarnMissingDerivingStrategies)-               loc-               (if xopt LangExt.DerivingStrategies dyn_flags-                 then no_strat_warning-                 else no_strat_warning $+$ deriv_strat_nenabled-               )-             _ -> pure ()-       }-  where-    no_strat_warning :: SDoc-    no_strat_warning = text "No deriving strategy specified. Did you want stock"-                       <> text ", newtype, or anyclass?"-    deriv_strat_nenabled :: SDoc-    deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."--rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs-                    -> RnM (LHsDerivingClause GhcRn, FreeVars)-rnLHsDerivingClause doc-                (L loc (HsDerivingClause-                              { deriv_clause_ext = noExtField-                              , deriv_clause_strategy = dcs-                              , deriv_clause_tys = L loc' dct }))-  = do { (dcs', dct', fvs)-           <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct-       ; warnNoDerivStrat dcs' loc-       ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField-                                        , deriv_clause_strategy = dcs'-                                        , deriv_clause_tys = L loc' dct' })-              , fvs ) }-rnLHsDerivingClause _ (L _ (XHsDerivingClause nec))-  = noExtCon nec--rnLDerivStrategy :: forall a.-                    HsDocContext-                 -> Maybe (LDerivStrategy GhcPs)-                 -> RnM (a, FreeVars)-                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)-rnLDerivStrategy doc mds thing_inside-  = case mds of-      Nothing -> boring_case Nothing-      Just (L loc ds) ->-        setSrcSpan loc $ do-          (ds', thing, fvs) <- rn_deriv_strat ds-          pure (Just (L loc ds'), thing, fvs)-  where-    rn_deriv_strat :: DerivStrategy GhcPs-                   -> RnM (DerivStrategy GhcRn, a, FreeVars)-    rn_deriv_strat ds = do-      let extNeeded :: LangExt.Extension-          extNeeded-            | ViaStrategy{} <- ds-            = LangExt.DerivingVia-            | otherwise-            = LangExt.DerivingStrategies--      unlessXOptM extNeeded $-        failWith $ illegalDerivStrategyErr ds--      case ds of-        StockStrategy    -> boring_case StockStrategy-        AnyclassStrategy -> boring_case AnyclassStrategy-        NewtypeStrategy  -> boring_case NewtypeStrategy-        ViaStrategy via_ty ->-          do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty-             let HsIB { hsib_ext  = via_imp_tvs-                      , hsib_body = via_body } = via_ty'-                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body-                 via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs-                 via_tvs = via_imp_tvs ++ via_exp_tvs-             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside-             pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)--    boring_case :: ds -> RnM (ds, a, FreeVars)-    boring_case ds = do-      (thing, fvs) <- thing_inside-      pure (ds, thing, fvs)--badGadtStupidTheta :: HsDocContext -> SDoc-badGadtStupidTheta _-  = vcat [text "No context is allowed on a GADT-style data declaration",-          text "(You can put a context on each constructor, though.)"]--illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc-illegalDerivStrategyErr ds-  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds-         , text enableStrategy ]--  where-    enableStrategy :: String-    enableStrategy-      | ViaStrategy{} <- ds-      = "Use DerivingVia to enable this extension"-      | otherwise-      = "Use DerivingStrategies to enable this extension"--multipleDerivClausesErr :: SDoc-multipleDerivClausesErr-  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"-         , text "Use DerivingStrategies to allow this" ]--rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested-                        --             inside an *class decl* for cls-                        --             used for associated types-          -> FamilyDecl GhcPs-          -> RnM (FamilyDecl GhcRn, FreeVars)-rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars-                             , fdFixity = fixity-                             , fdInfo = info, fdResultSig = res_sig-                             , fdInjectivityAnn = injectivity })-  = do { tycon' <- lookupLocatedTopBndrRn tycon-       ; ((tyvars', res_sig', injectivity'), fv1) <--            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->-            do { let rn_sig = rnFamResultSig doc-               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig-               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')-                                          injectivity-               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }-       ; (info', fv2) <- rn_info tycon' info-       ; return (FamilyDecl { fdExt = noExtField-                            , fdLName = tycon', fdTyVars = tyvars'-                            , fdFixity = fixity-                            , fdInfo = info', fdResultSig = res_sig'-                            , fdInjectivityAnn = injectivity' }-                , fv1 `plusFV` fv2) }-  where-     doc = TyFamilyCtx tycon-     kvs = extractRdrKindSigVars res_sig--     -----------------------     rn_info :: Located Name-             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)-     rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns))-       = do { (eqns', fvs)-                <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))-                                          -- no class context-                          eqns-            ; return (ClosedTypeFamily (Just eqns'), fvs) }-     rn_info _ (ClosedTypeFamily Nothing)-       = return (ClosedTypeFamily Nothing, emptyFVs)-     rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)-     rn_info _ DataFamily     = return (DataFamily, emptyFVs)-rnFamDecl _ (XFamilyDecl nec) = noExtCon nec--rnFamResultSig :: HsDocContext-               -> FamilyResultSig GhcPs-               -> RnM (FamilyResultSig GhcRn, FreeVars)-rnFamResultSig _ (NoSig _)-   = return (NoSig noExtField, emptyFVs)-rnFamResultSig doc (KindSig _ kind)-   = do { (rndKind, ftvs) <- rnLHsKind doc kind-        ;  return (KindSig noExtField rndKind, ftvs) }-rnFamResultSig doc (TyVarSig _ tvbndr)-   = do { -- `TyVarSig` tells us that user named the result of a type family by-          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to-          -- be sure that the supplied result name is not identical to an-          -- already in-scope type variable from an enclosing class.-          ---          --  Example of disallowed declaration:-          --         class C a b where-          --            type F b = a | a -> b-          rdr_env <- getLocalRdrEnv-       ;  let resName = hsLTyVarName tvbndr-       ;  when (resName `elemLocalRdrEnv` rdr_env) $-          addErrAt (getLoc tvbndr) $-                     (hsep [ text "Type variable", quotes (ppr resName) <> comma-                           , text "naming a type family result,"-                           ] $$-                      text "shadows an already bound type variable")--       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for-                                      -- scoping checks that are irrelevant here-                          tvbndr $ \ tvbndr' ->-         return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }-rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec---- Note [Renaming injectivity annotation]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ During renaming of injectivity annotation we have to make several checks to--- make sure that it is well-formed.  At the moment injectivity annotation--- consists of a single injectivity condition, so the terms "injectivity--- annotation" and "injectivity condition" might be used interchangeably.  See--- Note [Injectivity annotation] for a detailed discussion of currently allowed--- injectivity annotations.------ Checking LHS is simple because the only type variable allowed on the LHS of--- injectivity condition is the variable naming the result in type family head.--- Example of disallowed annotation:------     type family Foo a b = r | b -> a------ Verifying RHS of injectivity consists of checking that:------  1. only variables defined in type family head appear on the RHS (kind---     variables are also allowed).  Example of disallowed annotation:------        type family Foo a = r | r -> b------  2. for associated types the result variable does not shadow any of type---     class variables. Example of disallowed annotation:------        class Foo a b where---           type F a = b | b -> a------ Breaking any of these assumptions results in an error.---- | Rename injectivity annotation. Note that injectivity annotation is just the--- part after the "|".  Everything that appears before it is renamed in--- rnFamDecl.-rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in-                                               --   type family head-                 -> LFamilyResultSig GhcRn     -- ^ Result signature-                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation-                 -> RnM (LInjectivityAnn GhcRn)-rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))-                 (L srcSpan (InjectivityAnn injFrom injTo))- = do-   { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)-          <- askNoErrs $-             bindLocalNames [hsLTyVarName resTv] $-             -- The return type variable scopes over the injectivity annotation-             -- e.g.   type family F a = (r::*) | r -> a-             do { injFrom' <- rnLTyVar injFrom-                ; injTo'   <- mapM rnLTyVar injTo-                ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }--   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs-         resName  = hsLTyVarName resTv-         -- See Note [Renaming injectivity annotation]-         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))-         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames--   -- if renaming of type variables ended with errors (eg. there were-   -- not-in-scope variables) don't check the validity of injectivity-   -- annotation. This gives better error messages.-   ; when (noRnErrors && not lhsValid) $-        addErrAt (getLoc injFrom)-              ( vcat [ text $ "Incorrect type variable on the LHS of "-                           ++ "injectivity condition"-              , nest 5-              ( vcat [ text "Expected :" <+> ppr resName-                     , text "Actual   :" <+> ppr injFrom ])])--   ; when (noRnErrors && not (Set.null rhsValid)) $-      do { let errorVars = Set.toList rhsValid-         ; addErrAt srcSpan $ ( hsep-                        [ text "Unknown type variable" <> plural errorVars-                        , text "on the RHS of injectivity condition:"-                        , interpp'SP errorVars ] ) }--   ; return injDecl' }---- We can only hit this case when the user writes injectivity annotation without--- naming the result:------   type family F a | result -> a---   type family F a :: * | result -> a------ So we rename injectivity annotation like we normally would except that--- this time we expect "result" to be reported not in scope by rnLTyVar.-rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =-   setSrcSpan srcSpan $ do-   (injDecl', _) <- askNoErrs $ do-     injFrom' <- rnLTyVar injFrom-     injTo'   <- mapM rnLTyVar injTo-     return $ L srcSpan (InjectivityAnn injFrom' injTo')-   return $ injDecl'--{--Note [Stupid theta]-~~~~~~~~~~~~~~~~~~~-#3850 complains about a regression wrt 6.10 for-     data Show a => T a-There is no reason not to allow the stupid theta if there are no data-constructors.  It's still stupid, but does no harm, and I don't want-to cause programs to break unnecessarily (notably HList).  So if there-are no data constructors we allow h98_style = True--}---{- *****************************************************-*                                                      *-     Support code for type/data declarations-*                                                      *-***************************************************** -}------------------wrongTyFamName :: Name -> Name -> SDoc-wrongTyFamName fam_tc_name eqn_tc_name-  = hang (text "Mismatched type name in type family instance.")-       2 (vcat [ text "Expected:" <+> ppr fam_tc_name-               , text "  Actual:" <+> ppr eqn_tc_name ])--------------------rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)-rnConDecls = mapFvRn (wrapLocFstM rnConDecl)--rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)-rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs-                           , con_mb_cxt = mcxt, con_args = args-                           , con_doc = mb_doc })-  = do  { _        <- addLocM checkConName name-        ; new_name <- lookupLocatedTopBndrRn name-        ; mb_doc'  <- rnMbLHsDoc mb_doc--        -- We bind no implicit binders here; this is just like-        -- a nested HsForAllTy.  E.g. consider-        --         data T a = forall (b::k). MkT (...)-        -- The 'k' will already be in scope from the bindHsQTyVars-        -- for the data decl itself. So we'll get-        --         data T {k} a = ...-        -- And indeed we may later discover (a::k).  But that's the-        -- scoping we get.  So no implicit binders at the existential forall--        ; let ctxt = ConDeclCtx [new_name]-        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))-                            Nothing ex_tvs $ \ new_ex_tvs ->-    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt-        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args-        ; let all_fvs  = fvs1 `plusFV` fvs2-        ; traceRn "rnConDecl" (ppr name <+> vcat-             [ text "ex_tvs:" <+> ppr ex_tvs-             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])--        ; return (decl { con_ext = noExtField-                       , con_name = new_name, con_ex_tvs = new_ex_tvs-                       , con_mb_cxt = new_context, con_args = new_args-                       , con_doc = mb_doc' },-                  all_fvs) }}--rnConDecl decl@(ConDeclGADT { con_names   = names-                            , con_forall  = L _ explicit_forall-                            , con_qvars   = qtvs-                            , con_mb_cxt  = mcxt-                            , con_args    = args-                            , con_res_ty  = res_ty-                            , con_doc = mb_doc })-  = do  { mapM_ (addLocM checkConName) names-        ; new_names <- mapM lookupLocatedTopBndrRn names-        ; mb_doc'   <- rnMbLHsDoc mb_doc--        ; let explicit_tkvs = hsQTvExplicit qtvs-              theta         = hsConDeclTheta mcxt-              arg_tys       = hsConDeclArgTys args--          -- We must ensure that we extract the free tkvs in left-to-right-          -- order of their appearance in the constructor type.-          -- That order governs the order the implicitly-quantified type-          -- variable, and hence the order needed for visible type application-          -- See #14808.-              free_tkvs = extractHsTvBndrs explicit_tkvs $-                          extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])--              ctxt    = ConDeclCtx new_names-              mb_ctxt = Just (inHsDocContext ctxt)--        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )-        ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->-          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->-    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt-        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args-        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty--        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3-              (args', res_ty')-                  = case args of-                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)-                      RecCon {}    -> (new_args, new_res_ty)-                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty-                                   -> ASSERT( null as )-                                      -- See Note [GADT abstract syntax] in GHC.Hs.Decls-                                      (PrefixCon arg_tys, final_res_ty)--              new_qtvs =  HsQTvs { hsq_ext = implicit_tkvs-                                 , hsq_explicit  = explicit_tkvs }--        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)-        ; return (decl { con_g_ext = noExtField, con_names = new_names-                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt-                       , con_args = args', con_res_ty = res_ty'-                       , con_doc = mb_doc' },-                  all_fvs) } }--rnConDecl (XConDecl nec) = noExtCon nec---rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)-            -> RnM (Maybe (LHsContext GhcRn), FreeVars)-rnMbContext _    Nothing    = return (Nothing, emptyFVs)-rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt-                                ; return (Just ctx',fvs) }--rnConDeclDetails-   :: Name-   -> HsDocContext-   -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])-   -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),-           FreeVars)-rnConDeclDetails _ doc (PrefixCon tys)-  = do { (new_tys, fvs) <- rnLHsTypes doc tys-       ; return (PrefixCon new_tys, fvs) }--rnConDeclDetails _ doc (InfixCon ty1 ty2)-  = do { (new_ty1, fvs1) <- rnLHsType doc ty1-       ; (new_ty2, fvs2) <- rnLHsType doc ty2-       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }--rnConDeclDetails con doc (RecCon (L l fields))-  = do  { fls <- lookupConstructorFields con-        ; (new_fields, fvs) <- rnConDeclFields doc fls fields-                -- No need to check for duplicate fields-                -- since that is done by RnNames.extendGlobalRdrEnvRn-        ; return (RecCon (L l new_fields), fvs) }------------------------------------------------------- | Brings pattern synonym names and also pattern synonym selectors--- from record pattern synonyms into scope.-extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv-                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a-extendPatSynEnv val_decls local_fix_env thing = do {-     names_with_fls <- new_ps val_decls-   ; let pat_syn_bndrs = concat [ name: map flSelector fields-                                | (name, fields) <- names_with_fls ]-   ; let avails = map avail pat_syn_bndrs-   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env--   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls-         final_gbl_env = gbl_env { tcg_field_env = field_env' }-   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }-  where-    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]-    new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds-    new_ps _ = panic "new_ps"--    new_ps' :: LHsBindLR GhcPs GhcPs-            -> [(Name, [FieldLabel])]-            -> TcM [(Name, [FieldLabel])]-    new_ps' bind names-      | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n-                                       , psb_args = RecCon as }))) <- bind-      = do-          bnd_name <- newTopSrcBinder (L bind_loc n)-          let rnames = map recordPatSynSelectorId as-              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs-              mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name))-              field_occs =  map mkFieldOcc rnames-          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs-          return ((bnd_name, flds): names)-      | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind-      = do-        bnd_name <- newTopSrcBinder (L bind_loc n)-        return ((bnd_name, []): names)-      | otherwise-      = return names--{--*********************************************************-*                                                      *-\subsection{Support code to rename types}-*                                                      *-*********************************************************--}--rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]-rnFds fds-  = mapM (wrapLocM rn_fds) fds-  where-    rn_fds (tys1, tys2)-      = do { tys1' <- rnHsTyVars tys1-           ; tys2' <- rnHsTyVars tys2-           ; return (tys1', tys2') }--rnHsTyVars :: [Located RdrName] -> RnM [Located Name]-rnHsTyVars tvs  = mapM rnHsTyVar tvs--rnHsTyVar :: Located RdrName -> RnM (Located Name)-rnHsTyVar (L l tyvar) = do-  tyvar' <- lookupOccRn tyvar-  return (L l tyvar')--{--*********************************************************-*                                                      *-        findSplice-*                                                      *-*********************************************************--This code marches down the declarations, looking for the first-Template Haskell splice.  As it does so it-        a) groups the declarations into a HsGroup-        b) runs any top-level quasi-quotes--}--findSplice :: [LHsDecl GhcPs]-           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))-findSplice ds = addl emptyRdrGroup ds--addl :: HsGroup GhcPs -> [LHsDecl GhcPs]-     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))--- This stuff reverses the declarations (again) but it doesn't matter-addl gp []           = return (gp, Nothing)-addl gp (L l d : ds) = add gp l d ds---add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]-    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))---- #10047: Declaration QuasiQuoters are expanded immediately, without---         causing a group split-add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds-  = do { (ds', _) <- rnTopSpliceDecls qq-       ; addl gp (ds' ++ ds)-       }--add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds-  = do { -- We've found a top-level splice.  If it is an *implicit* one-         -- (i.e. a naked top level expression)-         case flag of-           ExplicitSplice -> return ()-           ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell-                                ; unless th_on $ setSrcSpan loc $-                                  failWith badImplicitSplice }--       ; return (gp, Just (splice, ds)) }-  where-    badImplicitSplice = text "Parse error: module header, import declaration"-                     $$ text "or top-level declaration expected."-                     -- The compiler should suggest the above, and not using-                     -- TemplateHaskell since the former suggestion is more-                     -- relevant to the larger base of users.-                     -- See #12146 for discussion.---- Class declarations: pull out the fixity signatures to the top-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds-  | isClassDecl d-  = let fsigs = [ L l f-                | L l (FixSig _ f) <- tcdSigs d ] in-    addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds-  | otherwise-  = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds---- Signatures: fixity sigs go a different place than all others-add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds-  = addl (gp {hs_fixds = L l f : ts}) ds---- Standalone kind signatures: added to the TyClGroup-add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds-  = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds--add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds-  = addl (gp {hs_valds = add_sig (L l d) ts}) ds---- Value declarations: use add_bind-add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds-  = addl (gp { hs_valds = add_bind (L l d) ts }) ds---- Role annotations: added to the TyClGroup-add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds-  = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds---- NB instance declarations go into TyClGroups. We throw them into the first--- group, just as we do for the TyClD case. The renamer will go on to group--- and order them later.-add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds-  = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds---- The rest are routine-add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds-  = addl (gp { hs_derivds = L l d : ts }) ds-add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds-  = addl (gp { hs_defds = L l d : ts }) ds-add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds-  = addl (gp { hs_fords = L l d : ts }) ds-add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds-  = addl (gp { hs_warnds = L l d : ts }) ds-add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds-  = addl (gp { hs_annds = L l d : ts }) ds-add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds-  = addl (gp { hs_ruleds = L l d : ts }) ds-add gp l (DocD _ d) ds-  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds-add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec-add (HsGroup {}) _ (XHsDecl nec)                 _ = noExtCon nec-add (XHsGroup nec) _ _                           _ = noExtCon nec--add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]-          -> [TyClGroup (GhcPass p)]-add_tycld d []       = [TyClGroup { group_ext    = noExtField-                                  , group_tyclds = [d]-                                  , group_kisigs = []-                                  , group_roles  = []-                                  , group_instds = []-                                  }-                       ]-add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)-  = ds { group_tyclds = d : tyclds } : dss-add_tycld _ (XTyClGroup nec: _) = noExtCon nec--add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]-          -> [TyClGroup (GhcPass p)]-add_instd d []       = [TyClGroup { group_ext    = noExtField-                                  , group_tyclds = []-                                  , group_kisigs = []-                                  , group_roles  = []-                                  , group_instds = [d]-                                  }-                       ]-add_instd d (ds@(TyClGroup { group_instds = instds }):dss)-  = ds { group_instds = d : instds } : dss-add_instd _ (XTyClGroup nec: _) = noExtCon nec--add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]-               -> [TyClGroup (GhcPass p)]-add_role_annot d [] = [TyClGroup { group_ext    = noExtField-                                 , group_tyclds = []-                                 , group_kisigs = []-                                 , group_roles  = [d]-                                 , group_instds = []-                                 }-                      ]-add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)-  = tycls { group_roles = d : roles } : rest-add_role_annot _ (XTyClGroup nec: _) = noExtCon nec--add_kisig :: LStandaloneKindSig (GhcPass p)-         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]-add_kisig d [] = [TyClGroup { group_ext    = noExtField-                            , group_tyclds = []-                            , group_kisigs = [d]-                            , group_roles  = []-                            , group_instds = []-                            }-                 ]-add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)-  = tycls { group_kisigs = d : kisigs } : rest-add_kisig _ (XTyClGroup nec : _) = noExtCon nec--add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a-add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs-add_bind _ (XValBindsLR {})     = panic "RdrHsSyn:add_bind"--add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)-add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)-add_sig _ (XValBindsLR {})     = panic "RdrHsSyn:add_sig"
− compiler/rename/RnSplice.hs 
@@ -1,902 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module RnSplice (-        rnTopSpliceDecls,-        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,-        rnBracket,-        checkThLocalName-        , traceSplice, SpliceInfo(..)-  ) where--#include "HsVersions.h"--import GhcPrelude--import Name-import NameSet-import GHC.Hs-import RdrName-import TcRnMonad--import RnEnv-import RnUtils          ( HsDocContext(..), newLocalBndrRn )-import RnUnbound        ( isUnboundName )-import RnSource         ( rnSrcDecls, findSplice )-import RnPat            ( rnPat )-import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )-import Outputable-import Module-import SrcLoc-import RnTypes          ( rnLHsType )--import Control.Monad    ( unless, when )--import {-# SOURCE #-} RnExpr   ( rnLExpr )--import TcEnv            ( checkWellStaged )-import THNames          ( liftName )--import DynFlags-import FastString-import ErrUtils         ( dumpIfSet_dyn_printer, DumpFormat (..) )-import TcEnv            ( tcMetaTy )-import Hooks-import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName-                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )--import {-# SOURCE #-} TcExpr   ( tcPolyExpr )-import {-# SOURCE #-} TcSplice-    ( runMetaD-    , runMetaE-    , runMetaP-    , runMetaT-    , tcTopSpliceExpr-    )--import TcHsSyn--import GHCi.RemoteTypes ( ForeignRef )-import qualified Language.Haskell.TH as TH (Q)--import qualified GHC.LanguageExtensions as LangExt--{--************************************************************************-*                                                                      *-        Template Haskell brackets-*                                                                      *-************************************************************************--}--rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)-rnBracket e br_body-  = addErrCtxt (quotationCtxtDoc br_body) $-    do { -- Check that -XTemplateHaskellQuotes is enabled and available-         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes-       ; unless thQuotesEnabled $-           failWith ( vcat-                      [ text "Syntax error on" <+> ppr e-                      , text ("Perhaps you intended to use TemplateHaskell"-                              ++ " or TemplateHaskellQuotes") ] )--         -- Check for nested brackets-       ; cur_stage <- getStage-       ; case cur_stage of-           { Splice Typed   -> checkTc (isTypedBracket br_body)-                                       illegalUntypedBracket-           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))-                                       illegalTypedBracket-           ; RunSplice _    ->-               -- See Note [RunSplice ThLevel] in "TcRnTypes".-               pprPanic "rnBracket: Renaming bracket when running a splice"-                        (ppr e)-           ; Comp           -> return ()-           ; Brack {}       -> failWithTc illegalBracket-           }--         -- Brackets are desugared to code that mentions the TH package-       ; recordThUse--       ; case isTypedBracket br_body of-            True  -> do { traceRn "Renaming typed TH bracket" empty-                        ; (body', fvs_e) <--                          setStage (Brack cur_stage RnPendingTyped) $-                                   rn_bracket cur_stage br_body-                        ; return (HsBracket noExtField body', fvs_e) }--            False -> do { traceRn "Renaming untyped TH bracket" empty-                        ; ps_var <- newMutVar []-                        ; (body', fvs_e) <--                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $-                                   rn_bracket cur_stage br_body-                        ; pendings <- readMutVar ps_var-                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }-       }--rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)-rn_bracket outer_stage br@(VarBr x flg rdr_name)-  = do { name <- lookupOccRn rdr_name-       ; this_mod <- getModule--       ; when (flg && nameIsLocalOrFrom this_mod name) $-             -- Type variables can be quoted in TH. See #5721.-                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name-                    ; case mb_bind_lvl of-                        { Nothing -> return ()      -- Can happen for data constructors,-                                                    -- but nothing needs to be done for them--                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]-                             | isTopLevel top_lvl-                             -> when (isExternalName name) (keepAlive name)-                             | otherwise-                             -> do { traceRn "rn_bracket VarBr"-                                      (ppr name <+> ppr bind_lvl-                                                <+> ppr outer_stage)-                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)-                                             (quotedNameStageErr br) }-                        }-                    }-       ; return (VarBr x flg name, unitFV name) }--rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e-                            ; return (ExpBr x e', fvs) }--rn_bracket _ (PatBr x p)-  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)--rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t-                              ; return (TypBr x t', fvs) }--rn_bracket _ (DecBrL x decls)-  = do { group <- groupDecls decls-       ; gbl_env  <- getGblEnv-       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }-                          -- The emptyDUs is so that we just collect uses for this-                          -- group alone in the call to rnSrcDecls below-       ; (tcg_env, group') <- setGblEnv new_gbl_env $-                              rnSrcDecls group--              -- Discard the tcg_env; it contains only extra info about fixity-        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$-                   ppr (duUses (tcg_dus tcg_env)))-        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }-  where-    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)-    groupDecls decls-      = do { (group, mb_splice) <- findSplice decls-           ; case mb_splice of-           { Nothing -> return group-           ; Just (splice, rest) ->-               do { group' <- groupDecls rest-                  ; let group'' = appendGroups group group'-                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }-                  }-           }}--rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"--rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e-                               ; return (TExpBr x e', fvs) }--rn_bracket _ (XBracket nec) = noExtCon nec--quotationCtxtDoc :: HsBracket GhcPs -> SDoc-quotationCtxtDoc br_body-  = hang (text "In the Template Haskell quotation")-         2 (ppr br_body)--illegalBracket :: SDoc-illegalBracket =-    text "Template Haskell brackets cannot be nested" <+>-    text "(without intervening splices)"--illegalTypedBracket :: SDoc-illegalTypedBracket =-    text "Typed brackets may only appear in typed splices."--illegalUntypedBracket :: SDoc-illegalUntypedBracket =-    text "Untyped brackets may only appear in untyped splices."--quotedNameStageErr :: HsBracket GhcPs -> SDoc-quotedNameStageErr br-  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br-        , text "must be used at the same stage at which it is bound" ]---{--*********************************************************-*                                                      *-                Splices-*                                                      *-*********************************************************--Note [Free variables of typed splices]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider renaming this:-        f = ...-        h = ...$(thing "f")...--where the splice is a *typed* splice.  The splice can expand into-literally anything, so when we do dependency analysis we must assume-that it might mention 'f'.  So we simply treat all locally-defined-names as mentioned by any splice.  This is terribly brutal, but I-don't see what else to do.  For example, it'll mean that every-locally-defined thing will appear to be used, so no unused-binding-warnings.  But if we miss the dependency, then we might typecheck 'h'-before 'f', and that will crash the type checker because 'f' isn't in-scope.--Currently, I'm not treating a splice as also mentioning every import,-which is a bit inconsistent -- but there are a lot of them.  We might-thereby get some bogus unused-import warnings, but we won't crash the-type checker.  Not very satisfactory really.--Note [Renamer errors]-~~~~~~~~~~~~~~~~~~~~~-It's important to wrap renamer calls in checkNoErrs, because the-renamer does not fail for out of scope variables etc. Instead it-returns a bogus term/type, so that it can report more than one error.-We don't want the type checker to see these bogus unbound variables.--}--rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))-                                            -- Outside brackets, run splice-            -> (HsSplice GhcRn -> (PendingRnSplice, a))-                                            -- Inside brackets, make it pending-            -> HsSplice GhcPs-            -> RnM (a, FreeVars)-rnSpliceGen run_splice pend_splice splice-  = addErrCtxt (spliceCtxt splice) $ do-    { stage <- getStage-    ; case stage of-        Brack pop_stage RnPendingTyped-          -> do { checkTc is_typed_splice illegalUntypedSplice-                ; (splice', fvs) <- setStage pop_stage $-                                    rnSplice splice-                ; let (_pending_splice, result) = pend_splice splice'-                ; return (result, fvs) }--        Brack pop_stage (RnPendingUntyped ps_var)-          -> do { checkTc (not is_typed_splice) illegalTypedSplice-                ; (splice', fvs) <- setStage pop_stage $-                                    rnSplice splice-                ; let (pending_splice, result) = pend_splice splice'-                ; ps <- readMutVar ps_var-                ; writeMutVar ps_var (pending_splice : ps)-                ; return (result, fvs) }--        _ ->  do { (splice', fvs1) <- checkNoErrs $-                                      setStage (Splice splice_type) $-                                      rnSplice splice-                   -- checkNoErrs: don't attempt to run the splice if-                   -- renaming it failed; otherwise we get a cascade of-                   -- errors from e.g. unbound variables-                 ; (result, fvs2) <- run_splice splice'-                 ; return (result, fvs1 `plusFV` fvs2) } }-   where-     is_typed_splice = isTypedSplice splice-     splice_type = if is_typed_splice-                   then Typed-                   else Untyped------------------------ | Returns the result of running a splice and the modFinalizers collected--- during the execution.------ See Note [Delaying modFinalizers in untyped splices].-runRnSplice :: UntypedSpliceFlavour-            -> (LHsExpr GhcTc -> TcRn res)-            -> (res -> SDoc)    -- How to pretty-print res-                                -- Usually just ppr, but not for [Decl]-            -> HsSplice GhcRn   -- Always untyped-            -> TcRn (res, [ForeignRef (TH.Q ())])-runRnSplice flavour run_meta ppr_res splice-  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)--       ; let the_expr = case splice' of-                HsUntypedSplice _ _ _ e   ->  e-                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str-                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)-                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)-                HsSplicedT {}             -> pprPanic "runRnSplice" (ppr splice)-                XSplice nec               -> noExtCon nec--             -- Typecheck the expression-       ; meta_exp_ty   <- tcMetaTy meta_ty_name-       ; zonked_q_expr <- zonkTopLExpr =<<-                            tcTopSpliceExpr Untyped-                              (tcPolyExpr the_expr meta_exp_ty)--             -- Run the expression-       ; mod_finalizers_ref <- newTcRef []-       ; result <- setStage (RunSplice mod_finalizers_ref) $-                     run_meta zonked_q_expr-       ; mod_finalizers <- readTcRef mod_finalizers_ref-       ; traceSplice (SpliceInfo { spliceDescription = what-                                 , spliceIsDecl      = is_decl-                                 , spliceSource      = Just the_expr-                                 , spliceGenerated   = ppr_res result })--       ; return (result, mod_finalizers) }--  where-    meta_ty_name = case flavour of-                       UntypedExpSplice  -> expQTyConName-                       UntypedPatSplice  -> patQTyConName-                       UntypedTypeSplice -> typeQTyConName-                       UntypedDeclSplice -> decsQTyConName-    what = case flavour of-                  UntypedExpSplice  -> "expression"-                  UntypedPatSplice  -> "pattern"-                  UntypedTypeSplice -> "type"-                  UntypedDeclSplice -> "declarations"-    is_decl = case flavour of-                 UntypedDeclSplice -> True-                 _                 -> False---------------------makePending :: UntypedSpliceFlavour-            -> HsSplice GhcRn-            -> PendingRnSplice-makePending flavour (HsUntypedSplice _ _ n e)-  = PendingRnSplice flavour n e-makePending flavour (HsQuasiQuote _ n quoter q_span quote)-  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)-makePending _ splice@(HsTypedSplice {})-  = pprPanic "makePending" (ppr splice)-makePending _ splice@(HsSpliced {})-  = pprPanic "makePending" (ppr splice)-makePending _ splice@(HsSplicedT {})-  = pprPanic "makePending" (ppr splice)-makePending _ (XSplice nec)-  = noExtCon nec---------------------mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString-                 -> LHsExpr GhcRn--- Return the expression (quoter "...quote...")--- which is what we must run in a quasi-quote-mkQuasiQuoteExpr flavour quoter q_span quote-  = L q_span $ HsApp noExtField (L q_span-             $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector)))-                                quoterExpr)-                    quoteExpr-  where-    quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter)-    quoteExpr  = L q_span $! HsLit noExtField $! HsString NoSourceText quote-    quote_selector = case flavour of-                       UntypedExpSplice  -> quoteExpName-                       UntypedPatSplice  -> quotePatName-                       UntypedTypeSplice -> quoteTypeName-                       UntypedDeclSplice -> quoteDecName------------------------rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)--- Not exported...used for all-rnSplice (HsTypedSplice x hasParen splice_name expr)-  = do  { loc  <- getSrcSpanM-        ; n' <- newLocalBndrRn (L loc splice_name)-        ; (expr', fvs) <- rnLExpr expr-        ; return (HsTypedSplice x hasParen n' expr', fvs) }--rnSplice (HsUntypedSplice x hasParen splice_name expr)-  = do  { loc  <- getSrcSpanM-        ; n' <- newLocalBndrRn (L loc splice_name)-        ; (expr', fvs) <- rnLExpr expr-        ; return (HsUntypedSplice x hasParen n' expr', fvs) }--rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)-  = do  { loc  <- getSrcSpanM-        ; splice_name' <- newLocalBndrRn (L loc splice_name)--          -- Rename the quoter; akin to the HsVar case of rnExpr-        ; quoter' <- lookupOccRn quoter-        ; this_mod <- getModule-        ; when (nameIsLocalOrFrom this_mod quoter') $-          checkThLocalName quoter'--        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote-                                                             , unitFV quoter') }--rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)-rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)-rnSplice        (XSplice nec)   = noExtCon nec------------------------rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)-rnSpliceExpr splice-  = rnSpliceGen run_expr_splice pend_expr_splice splice-  where-    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)-    pend_expr_splice rn_splice-        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice)--    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)-    run_expr_splice rn_splice-      | isTypedSplice rn_splice   -- Run it later, in the type checker-      = do {  -- Ugh!  See Note [Splices] above-             traceRn "rnSpliceExpr: typed expression splice" empty-           ; lcl_rdr <- getLocalRdrEnv-           ; gbl_rdr <- getGlobalRdrEnv-           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr-                                                     , isLocalGRE gre]-                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)--           ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) }--      | otherwise  -- Run it here, see Note [Running splices in the Renamer]-      = do { traceRn "rnSpliceExpr: untyped expression splice" empty-           ; (rn_expr, mod_finalizers) <--                runRnSplice UntypedExpSplice runMetaE ppr rn_splice-           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)-             -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsPar noExtField $ HsSpliceE noExtField-                            . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                            . HsSplicedExpr <$>-                            lexpr3-                    , fvs)-           }--{- Note [Running splices in the Renamer]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Splices used to be run in the typechecker, which led to (#4364). Since the-renamer must decide which expressions depend on which others, and it cannot-reliably do this for arbitrary splices, we used to conservatively say that-splices depend on all other expressions in scope. Unfortunately, this led to-the problem of cyclic type declarations seen in (#4364). Instead, by-running splices in the renamer, we side-step the problem of determining-dependencies: by the time the dependency analysis happens, any splices have-already been run, and expression dependencies can be determined as usual.--However, see (#9813), for an example where we would like to run splices-*after* performing dependency analysis (that is, after renaming). It would be-desirable to typecheck "non-splicy" expressions (those expressions that do not-contain splices directly or via dependence on an expression that does) before-"splicy" expressions, such that types/expressions within the same declaration-group would be available to `reify` calls, for example consider the following:--> module M where->   data D = C->   f = 1->   g = $(mapM reify ['f, 'D, ''C] ...)--Compilation of this example fails since D/C/f are not in the type environment-and thus cannot be reified as they have not been typechecked by the time the-splice is renamed and thus run.--These requirements are at odds: we do not want to run splices in the renamer as-we wish to first determine dependencies and typecheck certain expressions,-making them available to reify, but cannot accurately determine dependencies-without running splices in the renamer!--Indeed, the conclusion of (#9813) was that it is not worth the complexity-to try and- a) implement and maintain the code for renaming/typechecking non-splicy-    expressions before splicy expressions,- b) explain to TH users which expressions are/not available to reify at any-    given point.---}--{- Note [Delaying modFinalizers in untyped splices]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When splices run in the renamer, 'reify' does not have access to the local-type environment (#11832, [1]).--For instance, in--> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])--'reify' cannot find @x@, because the local type environment is not yet-populated. To address this, we allow 'reify' execution to be deferred with-'addModFinalizer'.--> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)-                    [| return () |]-                )--The finalizer is run with the local type environment when type checking is-complete.--Since the local type environment is not available in the renamer, we annotate-the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where-@e@ is the result of splicing and @finalizers@ are the finalizers that have been-collected during evaluation of the splice [3]. In our example,--> HsLet->   (x = e)->   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]->                          (HsSplicedExpr $ return ())->   )--When the typechecker finds the annotation, it inserts the finalizers in the-global environment and exposes the current local environment to them [4, 5, 6].--> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]--References:--[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify-[2] 'rnSpliceExpr'-[3] 'TcSplice.qAddModFinalizer'-[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))-[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))-[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))---}-------------------------rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)-rnSpliceType splice-  = rnSpliceGen run_type_splice pend_type_splice splice-  where-    pend_type_splice rn_splice-       = ( makePending UntypedTypeSplice rn_splice-         , HsSpliceTy noExtField rn_splice)--    run_type_splice rn_splice-      = do { traceRn "rnSpliceType: untyped type splice" empty-           ; (hs_ty2, mod_finalizers) <--                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice-           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2-                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }-                                    -- checkNoErrs: see Note [Renamer errors]-             -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsParTy noExtField-                              $ HsSpliceTy noExtField-                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                              . HsSplicedTy <$>-                              hs_ty3-                    , fvs-                    ) }-              -- Wrap the result of the splice in parens so that we don't-              -- lose the outermost location set by runQuasiQuote (#7918)--{- Note [Partial Type Splices]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Partial Type Signatures are partially supported in TH type splices: only-anonymous wild cards are allowed.--  -- ToDo: SLPJ says: I don't understand all this--Normally, named wild cards are collected before renaming a (partial) type-signature. However, TH type splices are run during renaming, i.e. after the-initial traversal, leading to out of scope errors for named wild cards. We-can't just extend the initial traversal to collect the named wild cards in TH-type splices, as we'd need to expand them, which is supposed to happen only-once, during renaming.--Similarly, the extra-constraints wild card is handled right before renaming-too, and is therefore also not supported in a TH type splice. Another reason-to forbid extra-constraints wild cards in TH type splices is that a single-signature can contain many TH type splices, whereas it mustn't contain more-than one extra-constraints wild card. Enforcing would this be hard the way-things are currently organised.--Anonymous wild cards pose no problem, because they start out without names and-are given names during renaming. These names are collected right after-renaming. The names generated for anonymous wild cards in TH type splices will-thus be collected as well.--For more details about renaming wild cards, see RnTypes.rnHsSigWcType--Note that partial type signatures are fully supported in TH declaration-splices, e.g.:--     [d| foo :: _ => _-         foo x y = x == y |]--This is because in this case, the partial type signature can be treated as a-whole signature, instead of as an arbitrary type.---}---------------------------- | Rename a splice pattern. See Note [rnSplicePat]-rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)-                                       , FreeVars)-rnSplicePat splice-  = rnSpliceGen run_pat_splice pend_pat_splice splice-  where-    pend_pat_splice :: HsSplice GhcRn ->-                       (PendingRnSplice, Either b (Pat GhcRn))-    pend_pat_splice rn_splice-      = (makePending UntypedPatSplice rn_splice-        , Right (SplicePat noExtField rn_splice))--    run_pat_splice :: HsSplice GhcRn ->-                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)-    run_pat_splice rn_splice-      = do { traceRn "rnSplicePat: untyped pattern splice" empty-           ; (pat, mod_finalizers) <--                runRnSplice UntypedPatSplice runMetaP ppr rn_splice-             -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField)-                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                              . HsSplicedPat)  `mapLoc`-                              pat-                    , emptyFVs-                    ) }-              -- Wrap the result of the quasi-quoter in parens so that we don't-              -- lose the outermost location set by runQuasiQuote (#7918)-------------------------rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)-rnSpliceDecl (SpliceDecl _ (L loc splice) flg)-  = rnSpliceGen run_decl_splice pend_decl_splice splice-  where-    pend_decl_splice rn_splice-       = ( makePending UntypedDeclSplice rn_splice-         , SpliceDecl noExtField (L loc rn_splice) flg)--    run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (ppr rn_splice)-rnSpliceDecl (XSpliceDecl nec) = noExtCon nec--rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)--- Declaration splice at the very top level of the module-rnTopSpliceDecls splice-   = do  { (rn_splice, fvs) <- checkNoErrs $-                               setStage (Splice Untyped) $-                               rnSplice splice-           -- As always, be sure to checkNoErrs above lest we end up with-           -- holes making it to typechecking, hence #12584.-           ---           -- Note that we cannot call checkNoErrs for the whole duration-           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes-           -- the local environment to temporarily contain a new-           -- reference to store errors, and add_mod_finalizers would-           -- cause this reference to be stored after checkNoErrs finishes.-           -- This is checked by test TH_finalizer.-         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty-         ; (decls, mod_finalizers) <- checkNoErrs $-               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice-         ; add_mod_finalizers_now mod_finalizers-         ; return (decls,fvs) }-   where-     ppr_decls :: [LHsDecl GhcPs] -> SDoc-     ppr_decls ds = vcat (map ppr ds)--     -- Adds finalizers to the global environment instead of delaying them-     -- to the type checker.-     ---     -- Declaration splices do not have an interesting local environment so-     -- there is no point in delaying them.-     ---     -- See Note [Delaying modFinalizers in untyped splices].-     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()-     add_mod_finalizers_now []             = return ()-     add_mod_finalizers_now mod_finalizers = do-       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv-       env <- getLclEnv-       updTcRef th_modfinalizers_var $ \fins ->-         (env, ThModFinalizers mod_finalizers) : fins---{--Note [rnSplicePat]-~~~~~~~~~~~~~~~~~~-Renaming a pattern splice is a bit tricky, because we need the variables-bound in the pattern to be in scope in the RHS of the pattern. This scope-management is effectively done by using continuation-passing style in-RnPat, through the CpsRn monad. We don't wish to be in that monad here-(it would create import cycles and generally conflict with renaming other-splices), so we really want to return a (Pat RdrName) -- the result of-running the splice -- which can then be further renamed in RnPat, in-the CpsRn monad.--The problem is that if we're renaming a splice within a bracket, we-*don't* want to run the splice now. We really do just want to rename-it to an HsSplice Name. Of course, then we can't know what variables-are bound within the splice. So we accept any unbound variables and-rename them again when the bracket is spliced in.  If a variable is brought-into scope by a pattern splice all is fine.  If it is not then an error is-reported.--In any case, when we're done in rnSplicePat, we'll either have a-Pat RdrName (the result of running a top-level splice) or a Pat Name-(the renamed nested splice). Thus, the awkward return type of-rnSplicePat.--}--spliceCtxt :: HsSplice GhcPs -> SDoc-spliceCtxt splice-  = hang (text "In the" <+> what) 2 (ppr splice)-  where-    what = case splice of-             HsUntypedSplice {} -> text "untyped splice:"-             HsTypedSplice   {} -> text "typed splice:"-             HsQuasiQuote    {} -> text "quasi-quotation:"-             HsSpliced       {} -> text "spliced expression:"-             HsSplicedT      {} -> text "spliced expression:"-             XSplice         {} -> text "spliced expression:"---- | The splice data to be logged-data SpliceInfo-  = SpliceInfo-    { spliceDescription  :: String-    , spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls-                                                  --        added by addTopDecls-    , spliceIsDecl       :: Bool    -- True <=> put the generate code in a file-                                    --          when -dth-dec-file is on-    , spliceGenerated    :: SDoc-    }-        -- Note that 'spliceSource' is *renamed* but not *typechecked*-        -- Reason (a) less typechecking crap-        --        (b) data constructors after type checking have been-        --            changed to their *wrappers*, and that makes them-        --            print always fully qualified---- | outputs splice information for 2 flags which have different output formats:--- `-ddump-splices` and `-dth-dec-file`-traceSplice :: SpliceInfo -> TcM ()-traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src-                        , spliceGenerated = gen, spliceIsDecl = is_decl })-  = do { loc <- case mb_src of-                   Nothing        -> getSrcSpanM-                   Just (L loc _) -> return loc-       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)--       ; when is_decl $  -- Raw material for -dth-dec-file-         do { dflags <- getDynFlags-            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file-                                             "" FormatHaskell (spliceCodeDoc loc) } }-  where-    -- `-ddump-splices`-    spliceDebugDoc :: SrcSpan -> SDoc-    spliceDebugDoc loc-      = let code = case mb_src of-                     Nothing -> ending-                     Just e  -> nest 2 (ppr (stripParensHsExpr e)) : ending-            ending = [ text "======>", nest 2 gen ]-        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)-               2 (sep code)--    -- `-dth-dec-file`-    spliceCodeDoc :: SrcSpan -> SDoc-    spliceCodeDoc loc-      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd-             , gen ]--illegalTypedSplice :: SDoc-illegalTypedSplice = text "Typed splices may not appear in untyped brackets"--illegalUntypedSplice :: SDoc-illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"--checkThLocalName :: Name -> RnM ()-checkThLocalName name-  | isUnboundName name   -- Do not report two errors for-  = return ()            --   $(not_in_scope args)--  | otherwise-  = do  { traceRn "checkThLocalName" (ppr name)-        ; mb_local_use <- getStageAndBindLevel name-        ; case mb_local_use of {-             Nothing -> return () ;  -- Not a locally-bound thing-             Just (top_lvl, bind_lvl, use_stage) ->-    do  { let use_lvl = thLevel use_stage-        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl-        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl-                                               <+> ppr use_stage-                                               <+> ppr use_lvl)-        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }-----------------------------------------checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel-                       -> Name -> TcM ()--- We are inside brackets, and (use_lvl > bind_lvl)--- Now we must check whether there's a cross-stage lift to do--- Examples   \x -> [| x |]---            [| map |]------ This code is similar to checkCrossStageLifting in TcExpr, but--- this is only run on *untyped* brackets.--checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name-  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets-  , use_lvl > bind_lvl                               -- Cross-stage condition-  = check_cross_stage_lifting top_lvl name ps_var-  | otherwise-  = return ()--check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()-check_cross_stage_lifting top_lvl name ps_var-  | isTopLevel top_lvl-        -- Top-level identifiers in this module,-        -- (which have External Names)-        -- are just like the imported case:-        -- no need for the 'lifting' treatment-        -- E.g.  this is fine:-        --   f x = x-        --   g y = [| f 3 |]-  = when (isExternalName name) (keepAlive name)-    -- See Note [Keeping things alive for Template Haskell]--  | otherwise-  =     -- Nested identifiers, such as 'x' in-        -- E.g. \x -> [| h x |]-        -- We must behave as if the reference to x was-        --      h $(lift x)-        -- We use 'x' itself as the SplicePointName, used by-        -- the desugarer to stitch it all back together.-        -- If 'x' occurs many times we may get many identical-        -- bindings of the same SplicePointName, but that doesn't-        -- matter, although it's a mite untidy.-    do  { traceRn "checkCrossStageLifting" (ppr name)--          -- Construct the (lift x) expression-        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)-              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr--          -- Update the pending splices-        ; ps <- readMutVar ps_var-        ; writeMutVar ps_var (pend_splice : ps) }--{--Note [Keeping things alive for Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f x = x+1-  g y = [| f 3 |]--Here 'f' is referred to from inside the bracket, which turns into data-and mentions only f's *name*, not 'f' itself. So we need some other-way to keep 'f' alive, lest it get dropped as dead code.  That's what-keepAlive does. It puts it in the keep-alive set, which subsequently-ensures that 'f' stays as a top level binding.--This must be done by the renamer, not the type checker (as of old),-because the type checker doesn't typecheck the body of untyped-brackets (#8540).--A thing can have a bind_lvl of outerLevel, but have an internal name:-   foo = [d| op = 3-             bop = op + 1 |]-Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is-bound inside a bracket.  That is because we don't even even record-binding levels for top-level things; the binding levels are in the-LocalRdrEnv.--So the occurrence of 'op' in the rhs of 'bop' looks a bit like a-cross-stage thing, but it isn't really.  And in fact we never need-to do anything here for top-level bound things, so all is fine, if-a bit hacky.--For these chaps (which have Internal Names) we don't want to put-them in the keep-alive set.--Note [Quoting names]-~~~~~~~~~~~~~~~~~~~~-A quoted name 'n is a bit like a quoted expression [| n |], except that we-have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing-the use-level to account for the brackets, the cases are:--        bind > use                      Error-        bind = use+1                    OK-        bind < use-                Imported things         OK-                Top-level things        OK-                Non-top-level           Error--where 'use' is the binding level of the 'n quote. (So inside the implied-bracket the level would be use+1.)--Examples:--  f 'map        -- OK; also for top-level defns of this module--  \x. f 'x      -- Not ok (bind = 1, use = 1)-                -- (whereas \x. f [| x |] might have been ok, by-                --                               cross-stage lifting--  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)--  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)--}
− compiler/rename/RnSplice.hs-boot 
@@ -1,14 +0,0 @@-module RnSplice where--import GhcPrelude-import GHC.Hs-import TcRnMonad-import NameSet---rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)-rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)-                                          , FreeVars )-rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)--rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
− compiler/rename/RnTypes.hs 
@@ -1,1784 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[RnSource]{Main pass of renamer}--}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}--module RnTypes (-        -- Type related stuff-        rnHsType, rnLHsType, rnLHsTypes, rnContext,-        rnHsKind, rnLHsKind, rnLHsTypeArgs,-        rnHsSigType, rnHsWcType,-        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,-        newTyVarNameRn,-        rnConDeclFields,-        rnLTyVar,--        -- Precence related stuff-        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,-        checkPrecMatch, checkSectionPrec,--        -- Binding related stuff-        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,-        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,-        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,-        extractHsTysRdrTyVarsDups,-        extractRdrKindSigVars, extractDataDefnKindVars,-        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,-        nubL, elemRdr-  ) where--import GhcPrelude--import {-# SOURCE #-} RnSplice( rnSpliceType )--import DynFlags-import GHC.Hs-import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )-import RnEnv-import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn-                        , pprHsDocContext, bindLocalNamesFV, typeAppErr-                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )-import RnFixity         ( lookupFieldFixityRn, lookupFixityRn-                        , lookupTyFixityRn )-import TcRnMonad-import RdrName-import PrelNames-import TysPrim          ( funTyConName )-import Name-import SrcLoc-import NameSet-import FieldLabel--import Util-import ListSetOps       ( deleteBys )-import BasicTypes       ( compareFixity, funTyFixity, negateFixity-                        , Fixity(..), FixityDirection(..), LexicalFixity(..)-                        , TypeOrKind(..) )-import Outputable-import FastString-import Maybes-import qualified GHC.LanguageExtensions as LangExt--import Data.List          ( nubBy, partition, (\\) )-import Control.Monad      ( unless, when )--#include "HsVersions.h"--{--These type renamers are in a separate module, rather than in (say) RnSource,-to break several loop.--*********************************************************-*                                                       *-           HsSigWcType (i.e with wildcards)-*                                                       *-*********************************************************--}--data HsSigWcTypeScoping = AlwaysBind-                          -- ^ Always bind any free tyvars of the given type,-                          --   regardless of whether we have a forall at the top-                        | BindUnlessForall-                          -- ^ Unless there's forall at the top, do the same-                          --   thing as 'AlwaysBind'-                        | NeverBind-                          -- ^ Never bind any free tyvars--rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs-              -> RnM (LHsSigWcType GhcRn, FreeVars)-rnHsSigWcType scoping doc sig_ty-  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->-    return (sig_ty', emptyFVs)--rnHsSigWcTypeScoped :: HsSigWcTypeScoping-                       -- AlwaysBind: for pattern type sigs and rules we /do/ want-                       --             to bring those type variables into scope, even-                       --             if there's a forall at the top which usually-                       --             stops that happening-                       -- e.g  \ (x :: forall a. a-> b) -> e-                       -- Here we do bring 'b' into scope-                    -> HsDocContext -> LHsSigWcType GhcPs-                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))-                    -> RnM (a, FreeVars)--- Used for---   - Signatures on binders in a RULE---   - Pattern type signatures--- Wildcards are allowed--- type signatures on binders only allowed with ScopedTypeVariables-rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside-  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables-       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)-       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside-       }--rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs-                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))-                  -> RnM (a, FreeVars)--- rn_hs_sig_wc_type is used for source-language type signatures-rn_hs_sig_wc_type scoping ctxt-                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})-                  thing_inside-  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty-       ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars-       ; let nwc_rdrs = nubL nwc_rdrs'-             bind_free_tvs = case scoping of-                               AlwaysBind       -> True-                               BindUnlessForall -> not (isLHsForAllTy hs_ty)-                               NeverBind        -> False-       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->-    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty-       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }-             ib_ty'  = HsIB { hsib_ext = vars-                            , hsib_body = hs_ty' }-       ; (res, fvs2) <- thing_inside sig_ty'-       ; return (res, fvs1 `plusFV` fvs2) } }-rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _-  = noExtCon nec-rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _-  = noExtCon nec--rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)-rnHsWcType ctxt (HsWC { hswc_body = hs_ty })-  = do { free_vars <- extractFilteredRdrTyVars hs_ty-       ; (nwc_rdrs, _) <- partition_nwcs free_vars-       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty-       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }-       ; return (sig_ty', fvs) }-rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec--rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs-         -> RnM ([Name], LHsType GhcRn, FreeVars)-rnWcBody ctxt nwc_rdrs hs_ty-  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs-       ; let env = RTKE { rtke_level = TypeLevel-                        , rtke_what  = RnTypeBody-                        , rtke_nwcs  = mkNameSet nwcs-                        , rtke_ctxt  = ctxt }-       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $-                          rn_lty env hs_ty-       ; return (nwcs, hs_ty', fvs) }-  where-    rn_lty env (L loc hs_ty)-      = setSrcSpan loc $-        do { (hs_ty', fvs) <- rn_ty env hs_ty-           ; return (L loc hs_ty', fvs) }--    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)-    -- A lot of faff just to allow the extra-constraints wildcard to appear-    rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs-                                , hst_body = hs_body })-      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->-        do { (hs_body', fvs) <- rn_lty env hs_body-           ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField-                                , hst_bndrs = tvs', hst_body = hs_body' }-                    , fvs) }--    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt-                        , hst_body = hs_ty })-      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt-      , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last-      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1-           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1-           ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]-           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }-                    , fvs1 `plusFV` fvs2) }--      | otherwise-      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt-           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty-           ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = L cx hs_ctxt'-                              , hst_body = hs_ty' }-                    , fvs1 `plusFV` fvs2) }--    rn_ty env hs_ty = rnHsTyKi env hs_ty--    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })---checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()--- Rename the extra-constraint spot in a type signature---    (blah, _) => type--- Check that extra-constraints are allowed at all, and--- if so that it's an anonymous wildcard-checkExtraConstraintWildCard env hs_ctxt-  = checkWildCard env mb_bad-  where-    mb_bad | not (extraConstraintWildCardsAllowed env)-           = Just base_msg-             -- Currently, we do not allow wildcards in their full glory in-             -- standalone deriving declarations. We only allow a single-             -- extra-constraints wildcard à la:-             ---             --   deriving instance _ => Eq (Foo a)-             ---             -- i.e., we don't support things like-             ---             --   deriving instance (Eq a, _) => Eq (Foo a)-           | DerivDeclCtx {} <- rtke_ctxt env-           , not (null hs_ctxt)-           = Just deriv_decl_msg-           | otherwise-           = Nothing--    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard-                   <+> text "not allowed"--    deriv_decl_msg-      = hang base_msg-           2 (vcat [ text "except as the sole constraint"-                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])--extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool-extraConstraintWildCardsAllowed env-  = case rtke_ctxt env of-      TypeSigCtx {}       -> True-      ExprWithTySigCtx {} -> True-      DerivDeclCtx {}     -> True-      StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls-      _                   -> False---- | Finds free type and kind variables in a type,---     without duplicates, and---     without variables that are already in scope in LocalRdrEnv---   NB: this includes named wildcards, which look like perfectly---       ordinary type variables at this point-extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups-extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty)---- | Finds free type and kind variables in a type,---     with duplicates, but---     without variables that are already in scope in LocalRdrEnv---   NB: this includes named wildcards, which look like perfectly---       ordinary type variables at this point-extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups-extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)---- | When the NamedWildCards extension is enabled, partition_nwcs--- removes type variables that start with an underscore from the--- FreeKiTyVars in the argument and returns them in a separate list.--- When the extension is disabled, the function returns the argument--- and empty list.  See Note [Renaming named wild cards]-partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)-partition_nwcs free_vars-  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards-       ; return $-           if wildcards_enabled-           then partition is_wildcard free_vars-           else ([], free_vars) }-  where-     is_wildcard :: Located RdrName -> Bool-     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))--{- Note [Renaming named wild cards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Identifiers starting with an underscore are always parsed as type variables.-It is only here in the renamer that we give the special treatment.-See Note [The wildcard story for types] in GHC.Hs.Types.--It's easy!  When we collect the implicitly bound type variables, ready-to bring them into scope, and NamedWildCards is on, we partition the-variables into the ones that start with an underscore (the named-wildcards) and the rest. Then we just add them to the hswc_wcs field-of the HsWildCardBndrs structure, and we are done.---*********************************************************-*                                                       *-           HsSigtype (i.e. no wildcards)-*                                                       *-****************************************************** -}--rnHsSigType :: HsDocContext-            -> TypeOrKind-            -> LHsSigType GhcPs-            -> RnM (LHsSigType GhcRn, FreeVars)--- Used for source-language type signatures--- that cannot have wildcards-rnHsSigType ctx level (HsIB { hsib_body = hs_ty })-  = do { traceRn "rnHsSigType" (ppr hs_ty)-       ; vars <- extractFilteredRdrTyVarsDups hs_ty-       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->-    do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty--       ; return ( HsIB { hsib_ext = vars-                       , hsib_body = body' }-                , fvs ) } }-rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec--rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables-                           -- E.g.  f :: forall a. a->b-                           --  we do not want to bring 'b' into scope, hence False-                           -- But   f :: a -> b-                           --  we want to bring both 'a' and 'b' into scope-                -> FreeKiTyVarsWithDups-                                   -- Free vars of hs_ty (excluding wildcards)-                                   -- May have duplicates, which is-                                   -- checked here-                -> ([Name] -> RnM (a, FreeVars))-                -> RnM (a, FreeVars)-rnImplicitBndrs bind_free_tvs-                fvs_with_dups-                thing_inside-  = do { let fvs = nubL fvs_with_dups-             real_fvs | bind_free_tvs = fvs-                      | otherwise     = []--       ; traceRn "rnImplicitBndrs" $-         vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ]--       ; loc <- getSrcSpanM-       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs--       ; bindLocalNamesFV vars $-         thing_inside vars }--{- ******************************************************-*                                                       *-           LHsType and HsType-*                                                       *-****************************************************** -}--{--rnHsType is here because we call it from loadInstDecl, and I didn't-want a gratuitous knot.--Note [Context quantification]-------------------------------Variables in type signatures are implicitly quantified-when (1) they are in a type signature not beginning-with "forall" or (2) in any qualified type T => R.-We are phasing out (2) since it leads to inconsistencies-(#4426):--data A = A (a -> a)           is an error-data A = A (Eq a => a -> a)   binds "a"-data A = A (Eq a => a -> b)   binds "a" and "b"-data A = A (() => a -> b)     binds "a" and "b"-f :: forall a. a -> b         is an error-f :: forall a. () => a -> b   is an error-f :: forall a. a -> (() => b) binds "a" and "b"--This situation is now considered to be an error. See rnHsTyKi for case-HsForAllTy Qualified.--Note [QualTy in kinds]-~~~~~~~~~~~~~~~~~~~~~~-I was wondering whether QualTy could occur only at TypeLevel.  But no,-we can have a qualified type in a kind too. Here is an example:--  type family F a where-    F Bool = Nat-    F Nat  = Type--  type family G a where-    G Type = Type -> Type-    G ()   = Nat--  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where-    MkX :: X 'True '()--See that k1 becomes Bool and k2 becomes (), so the equality is-satisfied. If I write MkX :: X 'True 'False, compilation fails with a-suitable message:--  MkX :: X 'True '()-    • Couldn't match kind ‘G Bool’ with ‘Nat’-      Expected kind: G Bool-        Actual kind: F Bool--However: in a kind, the constraints in the QualTy must all be-equalities; or at least, any kinds with a class constraint are-uninhabited.--}--data RnTyKiEnv-  = RTKE { rtke_ctxt  :: HsDocContext-         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?-         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?-         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards-    }--data RnTyKiWhat = RnTypeBody-                | RnTopConstraint   -- Top-level context of HsSigWcTypes-                | RnConstraint      -- All other constraints--instance Outputable RnTyKiEnv where-  ppr (RTKE { rtke_level = lev, rtke_what = what-            , rtke_nwcs = wcs, rtke_ctxt = ctxt })-    = text "RTKE"-      <+> braces (sep [ ppr lev, ppr what, ppr wcs-                      , pprHsDocContext ctxt ])--instance Outputable RnTyKiWhat where-  ppr RnTypeBody      = text "RnTypeBody"-  ppr RnTopConstraint = text "RnTopConstraint"-  ppr RnConstraint    = text "RnConstraint"--mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv-mkTyKiEnv cxt level what- = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet-        , rtke_what = what, rtke_ctxt = cxt }--isRnKindLevel :: RnTyKiEnv -> Bool-isRnKindLevel (RTKE { rtke_level = KindLevel }) = True-isRnKindLevel _                                 = False-----------------rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)-rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty--rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)-rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys--rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)-rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty--rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)-rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind--rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)-rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind---- renaming a type only, not a kind-rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs-                -> RnM (LHsTypeArg GhcRn, FreeVars)-rnLHsTypeArg ctxt (HsValArg ty)-   = do { (tys_rn, fvs) <- rnLHsType ctxt ty-        ; return (HsValArg tys_rn, fvs) }-rnLHsTypeArg ctxt (HsTypeArg l ki)-   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki-        ; return (HsTypeArg l kis_rn, fvs) }-rnLHsTypeArg _ (HsArgPar sp)-   = return (HsArgPar sp, emptyFVs)--rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]-                 -> RnM ([LHsTypeArg GhcRn], FreeVars)-rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args-----------------rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs-              -> RnM (LHsContext GhcRn, FreeVars)-rnTyKiContext env (L loc cxt)-  = do { traceRn "rncontext" (ppr cxt)-       ; let env' = env { rtke_what = RnConstraint }-       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt-       ; return (L loc cxt', fvs) }--rnContext :: HsDocContext -> LHsContext GhcPs-          -> RnM (LHsContext GhcRn, FreeVars)-rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta-----------------rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)-rnLHsTyKi env (L loc ty)-  = setSrcSpan loc $-    do { (ty', fvs) <- rnHsTyKi env ty-       ; return (L loc ty', fvs) }--rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)--rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars-                            , hst_body = tau })-  = do { checkPolyKinds env ty-       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)-                           Nothing tyvars $ \ tyvars' ->-    do { (tau',  fvs) <- rnLHsTyKi env tau-       ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField-                             , hst_bndrs = tyvars' , hst_body =  tau' }-                , fvs) } }--rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })-  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]-       ; (ctxt', fvs1) <- rnTyKiContext env lctxt-       ; (tau',  fvs2) <- rnLHsTyKi env tau-       ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'-                          , hst_body =  tau' }-                , fvs1 `plusFV` fvs2) }--rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))-  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $-         unlessXOptM LangExt.PolyKinds $ addErr $-         withHsDocContext (rtke_ctxt env) $-         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)-              , text "Perhaps you intended to use PolyKinds" ]-           -- Any type variable at the kind level is illegal without the use-           -- of PolyKinds (see #14710)-       ; name <- rnTyVar env rdr_name-       ; return (HsTyVar noExtField ip (L loc name), unitFV name) }--rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)-  = setSrcSpan (getLoc l_op) $-    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op-        ; fix   <- lookupTyFixityRn l_op'-        ; (ty1', fvs2) <- rnLHsTyKi env ty1-        ; (ty2', fvs3) <- rnLHsTyKi env ty2-        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2)-                               (unLoc l_op') fix ty1' ty2'-        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }--rnHsTyKi env (HsParTy _ ty)-  = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsParTy noExtField ty', fvs) }--rnHsTyKi env (HsBangTy _ b ty)-  = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsBangTy noExtField b ty', fvs) }--rnHsTyKi env ty@(HsRecTy _ flds)-  = do { let ctxt = rtke_ctxt env-       ; fls          <- get_fields ctxt-       ; (flds', fvs) <- rnConDeclFields ctxt fls flds-       ; return (HsRecTy noExtField flds', fvs) }-  where-    get_fields (ConDeclCtx names)-      = concatMapM (lookupConstructorFields . unLoc) names-    get_fields _-      = do { addErr (hang (text "Record syntax is illegal here:")-                                   2 (ppr ty))-           ; return [] }--rnHsTyKi env (HsFunTy _ ty1 ty2)-  = do { (ty1', fvs1) <- rnLHsTyKi env ty1-        -- Might find a for-all as the arg of a function type-       ; (ty2', fvs2) <- rnLHsTyKi env ty2-        -- Or as the result.  This happens when reading Prelude.hi-        -- when we find return :: forall m. Monad m -> forall a. a -> m a--        -- Check for fixity rearrangements-       ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2'-       ; return (res_ty, fvs1 `plusFV` fvs2) }--rnHsTyKi env listTy@(HsListTy _ ty)-  = do { data_kinds <- xoptM LangExt.DataKinds-       ; when (not data_kinds && isRnKindLevel env)-              (addErr (dataKindsErr env listTy))-       ; (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsListTy noExtField ty', fvs) }--rnHsTyKi env t@(HsKindSig _ ty k)-  = do { checkPolyKinds env t-       ; kind_sigs_ok <- xoptM LangExt.KindSignatures-       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)-       ; (ty', lhs_fvs) <- rnLHsTyKi env ty-       ; (k', sig_fvs)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k-       ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }---- Unboxed tuples are allowed to have poly-typed arguments.  These--- sometimes crop up as a result of CPR worker-wrappering dictionaries.-rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)-  = do { data_kinds <- xoptM LangExt.DataKinds-       ; when (not data_kinds && isRnKindLevel env)-              (addErr (dataKindsErr env tupleTy))-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsTupleTy noExtField tup_con tys', fvs) }--rnHsTyKi env sumTy@(HsSumTy _ tys)-  = do { data_kinds <- xoptM LangExt.DataKinds-       ; when (not data_kinds && isRnKindLevel env)-              (addErr (dataKindsErr env sumTy))-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsSumTy noExtField tys', fvs) }---- Ensure that a type-level integer is nonnegative (#8306, #8412)-rnHsTyKi env tyLit@(HsTyLit _ t)-  = do { data_kinds <- xoptM LangExt.DataKinds-       ; unless data_kinds (addErr (dataKindsErr env tyLit))-       ; when (negLit t) (addErr negLitErr)-       ; checkPolyKinds env tyLit-       ; return (HsTyLit noExtField t, emptyFVs) }-  where-    negLit (HsStrTy _ _) = False-    negLit (HsNumTy _ i) = i < 0-    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit--rnHsTyKi env (HsAppTy _ ty1 ty2)-  = do { (ty1', fvs1) <- rnLHsTyKi env ty1-       ; (ty2', fvs2) <- rnLHsTyKi env ty2-       ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }--rnHsTyKi env (HsAppKindTy l ty k)-  = do { kind_app <- xoptM LangExt.TypeApplications-       ; unless kind_app (addErr (typeAppErr "kind" k))-       ; (ty', fvs1) <- rnLHsTyKi env ty-       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k-       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }--rnHsTyKi env t@(HsIParamTy _ n ty)-  = do { notInKinds env t-       ; (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsIParamTy noExtField n ty', fvs) }--rnHsTyKi _ (HsStarTy _ isUni)-  = return (HsStarTy noExtField isUni, emptyFVs)--rnHsTyKi _ (HsSpliceTy _ sp)-  = rnSpliceType sp--rnHsTyKi env (HsDocTy _ ty haddock_doc)-  = do { (ty', fvs) <- rnLHsTyKi env ty-       ; haddock_doc' <- rnLHsDoc haddock_doc-       ; return (HsDocTy noExtField ty' haddock_doc', fvs) }--rnHsTyKi _ (XHsType (NHsCoreTy ty))-  = return (XHsType (NHsCoreTy ty), emptyFVs)-    -- The emptyFVs probably isn't quite right-    -- but I don't think it matters--rnHsTyKi env ty@(HsExplicitListTy _ ip tys)-  = do { checkPolyKinds env ty-       ; data_kinds <- xoptM LangExt.DataKinds-       ; unless data_kinds (addErr (dataKindsErr env ty))-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsExplicitListTy noExtField ip tys', fvs) }--rnHsTyKi env ty@(HsExplicitTupleTy _ tys)-  = do { checkPolyKinds env ty-       ; data_kinds <- xoptM LangExt.DataKinds-       ; unless data_kinds (addErr (dataKindsErr env ty))-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsExplicitTupleTy noExtField tys', fvs) }--rnHsTyKi env (HsWildCardTy _)-  = do { checkAnonWildCard env-       ; return (HsWildCardTy noExtField, emptyFVs) }-----------------rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name-rnTyVar env rdr_name-  = do { name <- lookupTypeOccRn rdr_name-       ; checkNamedWildCard env name-       ; return name }--rnLTyVar :: Located RdrName -> RnM (Located Name)--- Called externally; does not deal with wildards-rnLTyVar (L loc rdr_name)-  = do { tyvar <- lookupTypeOccRn rdr_name-       ; return (L loc tyvar) }-----------------rnHsTyOp :: Outputable a-         => RnTyKiEnv -> a -> Located RdrName-         -> RnM (Located Name, FreeVars)-rnHsTyOp env overall_ty (L loc op)-  = do { ops_ok <- xoptM LangExt.TypeOperators-       ; op' <- rnTyVar env op-       ; unless (ops_ok || op' `hasKey` eqTyConKey) $-           addErr (opTyErr op overall_ty)-       ; let l_op' = L loc op'-       ; return (l_op', unitFV op') }-----------------notAllowed :: SDoc -> SDoc-notAllowed doc-  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")--checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()-checkWildCard env (Just doc)-  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]-checkWildCard _ Nothing-  = return ()--checkAnonWildCard :: RnTyKiEnv -> RnM ()--- Report an error if an anonymous wildcard is illegal here-checkAnonWildCard env-  = checkWildCard env mb_bad-  where-    mb_bad :: Maybe SDoc-    mb_bad | not (wildCardsAllowed env)-           = Just (notAllowed pprAnonWildCard)-           | otherwise-           = case rtke_what env of-               RnTypeBody      -> Nothing-               RnTopConstraint -> Just constraint_msg-               RnConstraint    -> Just constraint_msg--    constraint_msg = hang-                         (notAllowed pprAnonWildCard <+> text "in a constraint")-                        2 hint_msg-    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"-                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]--checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()--- Report an error if a named wildcard is illegal here-checkNamedWildCard env name-  = checkWildCard env mb_bad-  where-    mb_bad | not (name `elemNameSet` rtke_nwcs env)-           = Nothing  -- Not a wildcard-           | not (wildCardsAllowed env)-           = Just (notAllowed (ppr name))-           | otherwise-           = case rtke_what env of-               RnTypeBody      -> Nothing   -- Allowed-               RnTopConstraint -> Nothing   -- Allowed; e.g.-                  -- f :: (Eq _a) => _a -> Int-                  -- g :: (_a, _b) => T _a _b -> Int-                  -- The named tyvars get filled in from elsewhere-               RnConstraint    -> Just constraint_msg-    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"--wildCardsAllowed :: RnTyKiEnv -> Bool--- ^ In what contexts are wildcards permitted-wildCardsAllowed env-   = case rtke_ctxt env of-       TypeSigCtx {}       -> True-       TypBrCtx {}         -> True   -- Template Haskell quoted type-       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice-       ExprWithTySigCtx {} -> True-       PatCtx {}           -> True-       RuleCtx {}          -> True-       FamPatCtx {}        -> True   -- Not named wildcards though-       GHCiCtx {}          -> True-       HsTypeCtx {}        -> True-       StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls-       _                   -> False---------------------- | Ensures either that we're in a type or that -XPolyKinds is set-checkPolyKinds :: Outputable ty-                => RnTyKiEnv-                -> ty      -- ^ type-                -> RnM ()-checkPolyKinds env ty-  | isRnKindLevel env-  = do { polykinds <- xoptM LangExt.PolyKinds-       ; unless polykinds $-         addErr (text "Illegal kind:" <+> ppr ty $$-                 text "Did you mean to enable PolyKinds?") }-checkPolyKinds _ _ = return ()--notInKinds :: Outputable ty-           => RnTyKiEnv-           -> ty-           -> RnM ()-notInKinds env ty-  | isRnKindLevel env-  = addErr (text "Illegal kind:" <+> ppr ty)-notInKinds _ _ = return ()--{- *****************************************************-*                                                      *-          Binding type variables-*                                                      *-***************************************************** -}--bindSigTyVarsFV :: [Name]-                -> RnM (a, FreeVars)-                -> RnM (a, FreeVars)--- Used just before renaming the defn of a function--- with a separate type signature, to bring its tyvars into scope--- With no -XScopedTypeVariables, this is a no-op-bindSigTyVarsFV tvs thing_inside-  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables-        ; if not scoped_tyvars then-                thing_inside-          else-                bindLocalNamesFV tvs thing_inside }---- | Simply bring a bunch of RdrNames into scope. No checking for--- validity, at all. The binding location is taken from the location--- on each name.-bindLRdrNames :: [Located RdrName]-              -> ([Name] -> RnM (a, FreeVars))-              -> RnM (a, FreeVars)-bindLRdrNames rdrs thing_inside-  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs-       ; bindLocalNamesFV var_names $-         thing_inside var_names }------------------bindHsQTyVars :: forall a b.-                 HsDocContext-              -> Maybe SDoc         -- Just d => check for unused tvs-                                    --   d is a phrase like "in the type ..."-              -> Maybe a            -- Just _  => an associated type decl-              -> [Located RdrName]  -- Kind variables from scope, no dups-              -> (LHsQTyVars GhcPs)-              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))-                  -- The Bool is True <=> all kind variables used in the-                  -- kind signature are bound on the left.  Reason:-                  -- the last clause of Note [CUSKs: Complete user-supplied-                  -- kind signatures] in GHC.Hs.Decls-              -> RnM (b, FreeVars)---- See Note [bindHsQTyVars examples]--- (a) Bring kind variables into scope---     both (i)  passed in body_kv_occs---     and  (ii) mentioned in the kinds of hsq_bndrs--- (b) Bring type variables into scope----bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside-  = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs-             bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs--       ; let -- See Note [bindHsQTyVars examples] for what-             -- all these various things are doing-             bndrs, kv_occs, implicit_kvs :: [Located RdrName]-             bndrs        = map hsLTyVarLocName hs_tv_bndrs-             kv_occs      = nubL (bndr_kv_occs ++ body_kv_occs)-                                 -- Make sure to list the binder kvs before the-                                 -- body kvs, as mandated by-                                 -- Note [Ordering of implicit variables]-             implicit_kvs = filter_occs bndrs kv_occs-             del          = deleteBys eqLocated-             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)--       ; traceRn "checkMixedVars3" $-           vcat [ text "kv_occs" <+> ppr kv_occs-                , text "bndrs"   <+> ppr hs_tv_bndrs-                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs-                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)-                ]--       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs--       ; bindLocalNamesFV implicit_kv_nms                     $-         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->-    do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)-       ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms-                              , hsq_explicit  = rn_bndrs })-                      all_bound_on_lhs } }--  where-    filter_occs :: [Located RdrName]   -- Bound here-                -> [Located RdrName]   -- Potential implicit binders-                -> [Located RdrName]   -- Final implicit binders-    -- Filter out any potential implicit binders that are either-    -- already in scope, or are explicitly bound in the same HsQTyVars-    filter_occs bndrs occs-      = filterOut is_in_scope occs-      where-        is_in_scope locc = locc `elemRdr` bndrs--{- Note [bindHsQTyVars examples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   data T k (a::k1) (b::k) :: k2 -> k1 -> *--Then:-  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables-  bndrs       = [k,a,b]--  bndr_kv_occs = [k,k1], kind variables free in kind signatures-                         of hs_tv_bndrs--  body_kv_occs = [k2,k1], kind variables free in the-                          result kind signature--  implicit_kvs = [k1,k2], kind variables free in kind signatures-                          of hs_tv_bndrs, and not bound by bndrs--* We want to quantify add implicit bindings for implicit_kvs--* If implicit_body_kvs is non-empty, then there is a kind variable-  mentioned in the kind signature that is not bound "on the left".-  That's one of the rules for a CUSK, so we pass that info on-  as the second argument to thing_inside.--* Order is not important in these lists.  All we are doing is-  bring Names into scope.--Finally, you may wonder why filter_occs removes in-scope variables-from bndr/body_kv_occs.  How can anything be in scope?  Answer:-HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax-ConDecls-   data T a = forall (b::k). MkT a b-The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire-ConDecl.  Hence the local RdrEnv may be non-empty and we must filter-out 'a' from the free vars.  (Mind you, in this situation all the-implicit kind variables are bound at the data type level, so there-are none to bind in the ConDecl, so there are no implicitly bound-variables at all.--Note [Kind variable scoping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-  data T (a :: k) k = ...-we report "k is out of scope" for (a::k).  Reason: k is not brought-into scope until the explicit k-binding that follows.  It would be-terribly confusing to bring into scope an /implicit/ k for a's kind-and a distinct, shadowing explicit k that follows, something like-  data T {k1} (a :: k1) k = ...--So the rule is:--   the implicit binders never include any-   of the explicit binders in the group--Note that in the denerate case-  data T (a :: a) = blah-we get a complaint the second 'a' is not in scope.--That applies to foralls too: e.g.-   forall (a :: k) k . blah--But if the foralls are split, we treat the two groups separately:-   forall (a :: k). forall k. blah-Here we bring into scope an implicit k, which is later shadowed-by the explicit k.--In implementation terms--* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete-  the binders {a,k}, and so end with no implicit binders.  Then we-  rename the binders left-to-right, and hence see that 'k' is out of-  scope in the kind of 'a'.--* Similarly in extract_hs_tv_bndrs--Note [Variables used as both types and kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We bind the type variables tvs, and kvs is the set of free variables of the-kinds in the scope of the binding. Here is one typical example:--   forall a b. a -> (b::k) -> (c::a)--Here, tvs will be {a,b}, and kvs {k,a}.--We must make sure that kvs includes all of variables in the kinds of type-variable bindings. For instance:--   forall k (a :: k). Proxy a--If we only look in the body of the `forall` type, we will mistakenly conclude-that kvs is {}. But in fact, the type variable `k` is also used as a kind-variable in (a :: k), later in the binding. (This mistake lead to #14710.)-So tvs is {k,a} and kvs is {k}.--NB: we do this only at the binding site of 'tvs'.--}--bindLHsTyVarBndrs :: HsDocContext-                  -> Maybe SDoc            -- Just d => check for unused tvs-                                           --   d is a phrase like "in the type ..."-                  -> Maybe a               -- Just _  => an associated type decl-                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars-                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))-                  -> RnM (b, FreeVars)-bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside-  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)-       ; checkDupRdrNames tv_names_w_loc-       ; go tv_bndrs thing_inside }-  where-    tv_names_w_loc = map hsLTyVarLocName tv_bndrs--    go []     thing_inside = thing_inside []-    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->-                             do { (res, fvs) <- go bs $ \ bs' ->-                                                thing_inside (b' : bs')-                                ; warn_unused b' fvs-                                ; return (res, fvs) }--    warn_unused tv_bndr fvs = case mb_in_doc of-      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs-      Nothing     -> return ()--bindLHsTyVarBndr :: HsDocContext-                 -> Maybe a   -- associated class-                 -> LHsTyVarBndr GhcPs-                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))-                 -> RnM (b, FreeVars)-bindLHsTyVarBndr _doc mb_assoc (L loc-                                 (UserTyVar x-                                    lrdr@(L lv _))) thing_inside-  = do { nm <- newTyVarNameRn mb_assoc lrdr-       ; bindLocalNamesFV [nm] $-         thing_inside (L loc (UserTyVar x (L lv nm))) }--bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))-                 thing_inside-  = do { sig_ok <- xoptM LangExt.KindSignatures-           ; unless sig_ok (badKindSigErr doc kind)-           ; (kind', fvs1) <- rnLHsKind doc kind-           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr-           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]-               $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))-           ; return (b, fvs1 `plusFV` fvs2) }--bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec--newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name-newTyVarNameRn mb_assoc (L loc rdr)-  = do { rdr_env <- getLocalRdrEnv-       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of-           (Just _, Just n) -> return n-              -- Use the same Name as the parent class decl--           _                -> newLocalBndrRn (L loc rdr) }-{--*********************************************************-*                                                       *-        ConDeclField-*                                                       *-*********************************************************--When renaming a ConDeclField, we have to find the FieldLabel-associated with each field.  But we already have all the FieldLabels-available (since they were brought into scope by-RnNames.getLocalNonValBinders), so we just take the list as an-argument, build a map and look them up.--}--rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]-                -> RnM ([LConDeclField GhcRn], FreeVars)--- Also called from RnSource--- No wildcards can appear in record fields-rnConDeclFields ctxt fls fields-   = mapFvRn (rnField fl_env env) fields-  where-    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody-    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]--rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs-        -> RnM (LConDeclField GhcRn, FreeVars)-rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))-  = do { let new_names = map (fmap lookupField) names-       ; (new_ty, fvs) <- rnLHsTyKi env ty-       ; new_haddock_doc <- rnMbLHsDoc haddock_doc-       ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc)-                , fvs) }-  where-    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn-    lookupField (FieldOcc _ (L lr rdr)) =-        FieldOcc (flSelector fl) (L lr rdr)-      where-        lbl = occNameFS $ rdrNameOcc rdr-        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl-    lookupField (XFieldOcc nec) = noExtCon nec-rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec--{--************************************************************************-*                                                                      *-        Fixities and precedence parsing-*                                                                      *-************************************************************************--@mkOpAppRn@ deals with operator fixities.  The argument expressions-are assumed to be already correctly arranged.  It needs the fixities-recorded in the OpApp nodes, because fixity info applies to the things-the programmer actually wrote, so you can't find it out from the Name.--Furthermore, the second argument is guaranteed not to be another-operator application.  Why? Because the parser parses all-operator applications left-associatively, EXCEPT negation, which-we need to handle specially.-Infix types are read in a *right-associative* way, so that-        a `op` b `op` c-is always read in as-        a `op` (b `op` c)--mkHsOpTyRn rearranges where necessary.  The two arguments-have already been renamed and rearranged.  It's made rather tiresome-by the presence of ->, which is a separate syntactic construct.--}-------------------- Building (ty1 `op1` (ty21 `op2` ty22))-mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)-           -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn-           -> RnM (HsType GhcRn)--mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22))-  = do  { fix2 <- lookupTyFixityRn op2-        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1-                      (\t1 t2 -> HsOpTy noExtField t1 op2 t2)-                      (unLoc op2) fix2 ty21 ty22 loc2 }--mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))-  = mk_hs_op_ty mk1 pp_op1 fix1 ty1-                (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2--mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment-  = return (mk1 ty1 ty2)------------------mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)-            -> Name -> Fixity -> LHsType GhcRn-            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)-            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan-            -> RnM (HsType GhcRn)-mk_hs_op_ty mk1 op1 fix1 ty1-            mk2 op2 fix2 ty21 ty22 loc2-  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)-                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }-  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))-  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)-                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21-                         ; return (mk2 (noLoc new_ty) ty22) }-  where-    (nofix_error, associate_right) = compareFixity fix1 fix2-------------------------------mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged-          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity-          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might-                                       -- be a NegApp)-          -> RnM (HsExpr GhcRn)---- (e11 `op1` e12) `op2` e2-mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2-  | nofix_error-  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)-       return (OpApp fix2 e1 op2 e2)--  | associate_right = do-    new_e <- mkOpAppRn e12 op2 fix2 e2-    return (OpApp fix1 e11 op1 (L loc' new_e))-  where-    loc'= combineLocs e12 e2-    (nofix_error, associate_right) = compareFixity fix1 fix2--------------------------------      (- neg_arg) `op` e2-mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2-  | nofix_error-  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)-       return (OpApp fix2 e1 op2 e2)--  | associate_right-  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2-       return (NegApp noExtField (L loc' new_e) neg_name)-  where-    loc' = combineLocs neg_arg e2-    (nofix_error, associate_right) = compareFixity negateFixity fix2--------------------------------      e1 `op` - neg_arg-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right-  | not associate_right                        -- We *want* right association-  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)-       return (OpApp fix1 e1 op1 e2)-  where-    (_, associate_right) = compareFixity fix1 negateFixity--------------------------------      Default case-mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment-  = ASSERT2( right_op_ok fix (unLoc e2),-             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2-    )-    return (OpApp fix e1 op e2)---------------------------------- | Name of an operator in an operator application or section-data OpName = NormalOp Name         -- ^ A normal identifier-            | NegateOp              -- ^ Prefix negation-            | UnboundOp OccName     -- ^ An unbound indentifier-            | RecFldOp (AmbiguousFieldOcc GhcRn)-              -- ^ A (possibly ambiguous) record field occurrence--instance Outputable OpName where-  ppr (NormalOp n)   = ppr n-  ppr NegateOp       = ppr negateName-  ppr (UnboundOp uv) = ppr uv-  ppr (RecFldOp fld) = ppr fld--get_op :: LHsExpr GhcRn -> OpName--- An unbound name could be either HsVar or HsUnboundVar--- See RnExpr.rnUnboundVar-get_op (L _ (HsVar _ n))         = NormalOp (unLoc n)-get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv-get_op (L _ (HsRecFld _ fld))    = RecFldOp fld-get_op other                     = pprPanic "get_op" (ppr other)---- Parser left-associates everything, but--- derived instances may have correctly-associated things to--- in the right operand.  So we just check that the right operand is OK-right_op_ok :: Fixity -> HsExpr GhcRn -> Bool-right_op_ok fix1 (OpApp fix2 _ _ _)-  = not error_please && associate_right-  where-    (error_please, associate_right) = compareFixity fix1 fix2-right_op_ok _ _-  = True---- Parser initially makes negation bind more tightly than any other operator--- And "deriving" code should respect this (use HsPar if not)-mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)-           -> RnM (HsExpr (GhcPass id))-mkNegAppRn neg_arg neg_name-  = ASSERT( not_op_app (unLoc neg_arg) )-    return (NegApp noExtField neg_arg neg_name)--not_op_app :: HsExpr id -> Bool-not_op_app (OpApp {}) = False-not_op_app _          = True------------------------------mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged-          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity-          -> LHsCmdTop GhcRn             -- Right operand (not an infix)-          -> RnM (HsCmd GhcRn)---- (e11 `op1` e12) `op2` e2-mkOpFormRn a1@(L loc-                    (HsCmdTop _-                     (L _ (HsCmdArrForm x op1 f (Just fix1)-                        [a11,a12]))))-        op2 fix2 a2-  | nofix_error-  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)-       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])--  | associate_right-  = do new_c <- mkOpFormRn a12 op2 fix2 a2-       return (HsCmdArrForm noExtField op1 f (Just fix1)-               [a11, L loc (HsCmdTop [] (L loc new_c))])-        -- TODO: locs are wrong-  where-    (nofix_error, associate_right) = compareFixity fix1 fix2----      Default case-mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment-  = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])------------------------------------------mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn-             -> RnM (Pat GhcRn)--mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2-  = do  { fix1 <- lookupFixityRn (unLoc op1)-        ; let (nofix_error, associate_right) = compareFixity fix1 fix2--        ; if nofix_error then do-                { precParseErr (NormalOp (unLoc op1),fix1)-                               (NormalOp (unLoc op2),fix2)-                ; return (ConPatIn op2 (InfixCon p1 p2)) }--          else if associate_right then do-                { new_p <- mkConOpPatRn op2 fix2 p12 p2-                ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) }-                -- XXX loc right?-          else return (ConPatIn op2 (InfixCon p1 p2)) }--mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment-  = ASSERT( not_op_pat (unLoc p2) )-    return (ConPatIn op (InfixCon p1 p2))--not_op_pat :: Pat GhcRn -> Bool-not_op_pat (ConPatIn _ (InfixCon _ _)) = False-not_op_pat _                           = True-----------------------------------------checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()-  -- Check precedence of a function binding written infix-  --   eg  a `op` b `C` c = ...-  -- See comments with rnExpr (OpApp ...) about "deriving"--checkPrecMatch op (MG { mg_alts = (L _ ms) })-  = mapM_ check ms-  where-    check (L _ (Match { m_pats = (L l1 p1)-                               : (L l2 p2)-                               : _ }))-      = setSrcSpan (combineSrcSpans l1 l2) $-        do checkPrec op p1 False-           checkPrec op p2 True--    check _ = return ()-        -- This can happen.  Consider-        --      a `op` True = ...-        --      op          = ...-        -- The infix flag comes from the first binding of the group-        -- but the second eqn has no args (an error, but not discovered-        -- until the type checker).  So we don't want to crash on the-        -- second eqn.-checkPrecMatch _ (XMatchGroup nec) = noExtCon nec--checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()-checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do-    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op-    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)-    let-        inf_ok = op1_prec > op_prec ||-                 (op1_prec == op_prec &&-                  (op1_dir == InfixR && op_dir == InfixR && right ||-                   op1_dir == InfixL && op_dir == InfixL && not right))--        info  = (NormalOp op,          op_fix)-        info1 = (NormalOp (unLoc op1), op1_fix)-        (infol, infor) = if right then (info, info1) else (info1, info)-    unless inf_ok (precParseErr infol infor)--checkPrec _ _ _-  = return ()---- Check precedence of (arg op) or (op arg) respectively--- If arg is itself an operator application, then either---   (a) its precedence must be higher than that of op---   (b) its precedency & associativity must be the same as that of op-checkSectionPrec :: FixityDirection -> HsExpr GhcPs-        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()-checkSectionPrec direction section op arg-  = case unLoc arg of-        OpApp fix _ op' _ -> go_for_it (get_op op') fix-        NegApp _ _ _      -> go_for_it NegateOp     negateFixity-        _                 -> return ()-  where-    op_name = get_op op-    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do-          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name-          unless (op_prec < arg_prec-                  || (op_prec == arg_prec && direction == assoc))-                 (sectionPrecErr (get_op op, op_fix)-                                 (arg_op, arg_fix) section)---- | Look up the fixity for an operator name.  Be careful to use--- 'lookupFieldFixityRn' for (possibly ambiguous) record fields--- (see #13132).-lookupFixityOp :: OpName -> RnM Fixity-lookupFixityOp (NormalOp n)  = lookupFixityRn n-lookupFixityOp NegateOp      = lookupFixityRn negateName-lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u)-lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f----- Precedence-related error messages--precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()-precParseErr op1@(n1,_) op2@(n2,_)-  | is_unbound n1 || is_unbound n2-  = return ()     -- Avoid error cascade-  | otherwise-  = addErr $ hang (text "Precedence parsing error")-      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),-               ppr_opfix op2,-               text "in the same infix expression"])--sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()-sectionPrecErr op@(n1,_) arg_op@(n2,_) section-  | is_unbound n1 || is_unbound n2-  = return ()     -- Avoid error cascade-  | otherwise-  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),-         nest 4 (sep [text "must have lower precedence than that of the operand,",-                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),-         nest 4 (text "in the section:" <+> quotes (ppr section))]--is_unbound :: OpName -> Bool-is_unbound (NormalOp n) = isUnboundName n-is_unbound UnboundOp{}  = True-is_unbound _            = False--ppr_opfix :: (OpName, Fixity) -> SDoc-ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)-   where-     pp_op | NegateOp <- op = text "prefix `-'"-           | otherwise      = quotes (ppr op)---{- *****************************************************-*                                                      *-                 Errors-*                                                      *-***************************************************** -}--unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc-unexpectedTypeSigErr ty-  = hang (text "Illegal type signature:" <+> quotes (ppr ty))-       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")--badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()-badKindSigErr doc (L loc ty)-  = setSrcSpan loc $ addErr $-    withHsDocContext doc $-    hang (text "Illegal kind signature:" <+> quotes (ppr ty))-       2 (text "Perhaps you intended to use KindSignatures")--dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc-dataKindsErr env thing-  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))-       2 (text "Perhaps you intended to use DataKinds")-  where-    pp_what | isRnKindLevel env = text "kind"-            | otherwise          = text "type"--inTypeDoc :: HsType GhcPs -> SDoc-inTypeDoc ty = text "In the type" <+> quotes (ppr ty)--warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()-warnUnusedForAll in_doc (L loc tv) used_names-  = whenWOptM Opt_WarnUnusedForalls $-    unless (hsTyVarName tv `elemNameSet` used_names) $-    addWarnAt (Reason Opt_WarnUnusedForalls) loc $-    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)-         , in_doc ]--opTyErr :: Outputable a => RdrName -> a -> SDoc-opTyErr op overall_ty-  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))-         2 (text "Use TypeOperators to allow operators in types")--{--************************************************************************-*                                                                      *-      Finding the free type variables of a (HsType RdrName)-*                                                                      *-************************************************************************---Note [Kind and type-variable binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a type signature we may implicitly bind type/kind variables. For example:-  *   f :: a -> a-      f = ...-    Here we need to find the free type variables of (a -> a),-    so that we know what to quantify--  *   class C (a :: k) where ...-    This binds 'k' in ..., as well as 'a'--  *   f (x :: a -> [a]) = ....-    Here we bind 'a' in ....--  *   f (x :: T a -> T (b :: k)) = ...-    Here we bind both 'a' and the kind variable 'k'--  *   type instance F (T (a :: Maybe k)) = ...a...k...-    Here we want to constrain the kind of 'a', and bind 'k'.--To do that, we need to walk over a type and find its free type/kind variables.-We preserve the left-to-right order of each variable occurrence.-See Note [Ordering of implicit variables].--Clients of this code can remove duplicates with nubL.--Note [Ordering of implicit variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the advent of -XTypeApplications, GHC makes promises about the ordering-of implicit variable quantification. Specifically, we offer that implicitly-quantified variables (such as those in const :: a -> b -> a, without a `forall`)-will occur in left-to-right order of first occurrence. Here are a few examples:--  const :: a -> b -> a       -- forall a b. ...-  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included--  type a <-< b = b -> a-  g :: a <-< b               -- forall a b. ...  type synonyms matter--  class Functor f where-    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...-    -- The f is quantified by the class, so only a and b are considered in fmap--This simple story is complicated by the possibility of dependency: all variables-must come after any variables mentioned in their kinds.--  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...--The k comes first because a depends on k, even though the k appears later than-the a in the code. Thus, GHC does ScopedSort on the variables.-See Note [ScopedSort] in Type.--Implicitly bound variables are collected by any function which returns a-FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably-includes the `extract-` family of functions (extractHsTysRdrTyVarsDups,-extractHsTyVarBndrsKVs, etc.).-These functions thus promise to keep left-to-right ordering.--Note [Implicit quantification in type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We typically bind type/kind variables implicitly when they are in a kind-annotation on the LHS, for example:--  data Proxy (a :: k) = Proxy-  type KindOf (a :: k) = k--Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and-we want to implicitly quantify over it.  This is easy: just extract all free-variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs--By contrast, on the RHS we can't simply collect *all* free variables. Which of-the following are allowed?--  type TySyn1 = a :: Type-  type TySyn2 = 'Nothing :: Maybe a-  type TySyn3 = 'Just ('Nothing :: Maybe a)-  type TySyn4 = 'Left a :: Either Type a--After some design deliberations (see non-taken alternatives below), the answer-is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.-We implicitly quantify over free variables of the outermost kind signature, if-one exists:--  * In TySyn1, the outermost kind signature is (:: Type), and it does not have-    any free variables.-  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a-    free variable 'a', which we implicitly quantify over.-  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature-    is hidden inside 'Just.-  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains-    a free variable 'a', which we implicitly quantify over. That is why we can-    also use it to the left of the double colon: 'Left a--The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type-synonyms and type family instances.--This is something of a stopgap solution until we can explicitly bind invisible-type/kind variables:--  type TySyn3 :: forall a. Maybe a-  type TySyn3 @a = 'Just ('Nothing :: Maybe a)--Note [Implicit quantification in type synonyms: non-taken alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Alternative I: No quantification----------------------------------We could offer no implicit quantification on the RHS, accepting none of the-TySyn<N> examples. The user would have to bind the variables explicitly:--  type TySyn1 a = a :: Type-  type TySyn2 a = 'Nothing :: Maybe a-  type TySyn3 a = 'Just ('Nothing :: Maybe a)-  type TySyn4 a = 'Left a :: Either Type a--However, this would mean that one would have to specify 'a' at call sites every-time, which could be undesired.--Alternative II: Indiscriminate quantification-----------------------------------------------We could implicitly quantify over all free variables on the RHS just like we do-on the LHS. Then we would infer the following kinds:--  TySyn1 :: forall {a}. Type-  TySyn2 :: forall {a}. Maybe a-  TySyn3 :: forall {a}. Maybe (Maybe a)-  TySyn4 :: forall {a}. Either Type a--This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable-is free-floating, not fixed by anything.--Alternative III: reportFloatingKvs------------------------------------We could augment Alternative II by hunting down free-floating variables during-type checking. While viable, this would mean we'd end up accepting this:--  data Prox k (a :: k)-  type T = Prox k---}---- See Note [Kind and type-variable binders]--- These lists are guaranteed to preserve left-to-right ordering of--- the types the variables were extracted from. See also--- Note [Ordering of implicit variables].-type FreeKiTyVars = [Located RdrName]---- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.-type FreeKiTyVarsWithDups = FreeKiTyVars---- | A 'FreeKiTyVars' list that contains no duplicate variables.-type FreeKiTyVarsNoDups   = FreeKiTyVars--filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars-filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)--filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars-filterInScopeM vars-  = do { rdr_env <- getLocalRdrEnv-       ; return (filterInScope rdr_env vars) }--inScope :: LocalRdrEnv -> RdrName -> Bool-inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env--extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_tyarg (HsValArg ty) acc = extract_lty ty acc-extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc-extract_tyarg (HsArgPar _) acc = acc--extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_tyargs args acc = foldr extract_tyarg acc args--extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups-extractHsTyArgRdrKiTyVarsDup args-  = extract_tyargs args []---- | 'extractHsTyRdrTyVars' finds the type/kind variables---                          of a HsType/HsKind.--- It's used when making the @forall@s explicit.--- When the same name occurs multiple times in the types, only the first--- occurrence is returned.--- See Note [Kind and type-variable binders]-extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups-extractHsTyRdrTyVars ty-  = nubL (extractHsTyRdrTyVarsDups ty)---- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables---                              of a HsType/HsKind.--- It's used when making the @forall@s explicit.--- When the same name occurs multiple times in the types, all occurrences--- are returned.-extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups-extractHsTyRdrTyVarsDups ty-  = extract_lty ty []---- | Extracts the free type/kind variables from the kind signature of a HsType.---   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.--- When the same name occurs multiple times in the type, only the first--- occurrence is returned, and the left-to-right order of variables is--- preserved.--- See Note [Kind and type-variable binders] and---     Note [Ordering of implicit variables] and---     Note [Implicit quantification in type synonyms].-extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups-extractHsTyRdrTyVarsKindVars (unLoc -> ty) =-  case ty of-    HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty-    HsKindSig _ _ ki -> extractHsTyRdrTyVars ki-    _ -> []---- | Extracts free type and kind variables from types in a list.--- When the same name occurs multiple times in the types, all occurrences--- are returned.-extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups-extractHsTysRdrTyVarsDups tys-  = extract_ltys tys []---- Returns the free kind variables of any explicitly-kinded binders, returning--- variable occurrences in left-to-right order.--- See Note [Ordering of implicit variables].--- NB: Does /not/ delete the binders themselves.---     However duplicates are removed---     E.g. given  [k1, a:k1, b:k2]---          the function returns [k1,k2], even though k1 is bound here-extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups-extractHsTyVarBndrsKVs tv_bndrs-  = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)---- Returns the free kind variables in a type family result signature, returning--- variable occurrences in left-to-right order.--- See Note [Ordering of implicit variables].-extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]-extractRdrKindSigVars (L _ resultSig)-  | KindSig _ k                          <- resultSig = extractHsTyRdrTyVars k-  | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k-  | otherwise =  []---- Get type/kind variables mentioned in the kind signature, preserving--- left-to-right order and without duplicates:------  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]---  * data T a (b :: k1)                             -- result: []------ See Note [Ordering of implicit variables].-extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVarsNoDups-extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })-  = maybe [] extractHsTyRdrTyVars ksig-extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec--extract_lctxt :: LHsContext GhcPs-              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_lctxt ctxt = extract_ltys (unLoc ctxt)--extract_ltys :: [LHsType GhcPs]-             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_ltys tys acc = foldr extract_lty acc tys--extract_lty :: LHsType GhcPs-            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_lty (L _ ty) acc-  = case ty of-      HsTyVar _ _  ltv            -> extract_tv ltv acc-      HsBangTy _ _ ty             -> extract_lty ty acc-      HsRecTy _ flds              -> foldr (extract_lty-                                            . cd_fld_type . unLoc) acc-                                           flds-      HsAppTy _ ty1 ty2           -> extract_lty ty1 $-                                     extract_lty ty2 acc-      HsAppKindTy _ ty k          -> extract_lty ty $-                                     extract_lty k acc-      HsListTy _ ty               -> extract_lty ty acc-      HsTupleTy _ _ tys           -> extract_ltys tys acc-      HsSumTy _ tys               -> extract_ltys tys acc-      HsFunTy _ ty1 ty2           -> extract_lty ty1 $-                                     extract_lty ty2 acc-      HsIParamTy _ _ ty           -> extract_lty ty acc-      HsOpTy _ ty1 tv ty2         -> extract_tv tv $-                                     extract_lty ty1 $-                                     extract_lty ty2 acc-      HsParTy _ ty                -> extract_lty ty acc-      HsSpliceTy {}               -> acc  -- Type splices mention no tvs-      HsDocTy _ ty _              -> extract_lty ty acc-      HsExplicitListTy _ _ tys    -> extract_ltys tys acc-      HsExplicitTupleTy _ tys     -> extract_ltys tys acc-      HsTyLit _ _                 -> acc-      HsStarTy _ _                -> acc-      HsKindSig _ ty ki           -> extract_lty ty $-                                     extract_lty ki acc-      HsForAllTy { hst_bndrs = tvs, hst_body = ty }-                                  -> extract_hs_tv_bndrs tvs acc $-                                     extract_lty ty []-      HsQualTy { hst_ctxt = ctxt, hst_body = ty }-                                  -> extract_lctxt ctxt $-                                     extract_lty ty acc-      XHsType {}                  -> acc-      -- We deal with these separately in rnLHsTypeWithWildCards-      HsWildCardTy {}             -> acc--extractHsTvBndrs :: [LHsTyVarBndr GhcPs]-                 -> FreeKiTyVarsWithDups           -- Free in body-                 -> FreeKiTyVarsWithDups       -- Free in result-extractHsTvBndrs tv_bndrs body_fvs-  = extract_hs_tv_bndrs tv_bndrs [] body_fvs--extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]-                    -> FreeKiTyVarsWithDups  -- Accumulator-                    -> FreeKiTyVarsWithDups  -- Free in body-                    -> FreeKiTyVarsWithDups--- In (forall (a :: Maybe e). a -> b) we have---     'a' is bound by the forall---     'b' is a free type variable---     'e' is a free kind variable-extract_hs_tv_bndrs tv_bndrs acc_vars body_vars-  | null tv_bndrs = body_vars ++ acc_vars-  | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars-    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.-    -- See Note [Kind variable scoping]-  where-    bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs-    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs--extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]--- Returns the free kind variables of any explicitly-kinded binders, returning--- variable occurrences in left-to-right order.--- See Note [Ordering of implicit variables].--- NB: Does /not/ delete the binders themselves.---     Duplicates are /not/ removed---     E.g. given  [k1, a:k1, b:k2]---          the function returns [k1,k2], even though k1 is bound here-extract_hs_tv_bndrs_kvs tv_bndrs =-    foldr extract_lty []-          [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]--extract_tv :: Located RdrName-           -> [Located RdrName] -> [Located RdrName]-extract_tv tv acc =-  if isRdrTyVar (unLoc tv) then tv:acc else acc---- Deletes duplicates in a list of Located things.------ Importantly, this function is stable with respect to the original ordering--- of things in the list. This is important, as it is a property that GHC--- relies on to maintain the left-to-right ordering of implicitly quantified--- type variables.--- See Note [Ordering of implicit variables].-nubL :: Eq a => [Located a] -> [Located a]-nubL = nubBy eqLocated--elemRdr :: Located RdrName -> [Located RdrName] -> Bool-elemRdr x = any (eqLocated x)
− compiler/rename/RnUnbound.hs 
@@ -1,381 +0,0 @@-{---This module contains helper functions for reporting and creating-unbound variables.---}-module RnUnbound ( mkUnboundName-                 , mkUnboundNameRdr-                 , isUnboundName-                 , reportUnboundName-                 , unknownNameSuggestions-                 , WhereLooking(..)-                 , unboundName-                 , unboundNameX-                 , notInScopeErr ) where--import GhcPrelude--import RdrName-import HscTypes-import TcRnMonad-import Name-import Module-import SrcLoc-import Outputable-import PrelNames ( mkUnboundName, isUnboundName, getUnique)-import Util-import Maybes-import DynFlags-import FastString-import Data.List-import Data.Function ( on )-import UniqDFM (udfmToList)--{--************************************************************************-*                                                                      *-               What to do when a lookup fails-*                                                                      *-************************************************************************--}--data WhereLooking = WL_Any        -- Any binding-                  | WL_Global     -- Any top-level binding (local or imported)-                  | WL_LocalTop   -- Any top-level binding in this module-                  | WL_LocalOnly-                        -- Only local bindings-                        -- (pattern synonyms declaractions,-                        -- see Note [Renaming pattern synonym variables])--mkUnboundNameRdr :: RdrName -> Name-mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)--reportUnboundName :: RdrName -> RnM Name-reportUnboundName rdr = unboundName WL_Any rdr--unboundName :: WhereLooking -> RdrName -> RnM Name-unboundName wl rdr = unboundNameX wl rdr Outputable.empty--unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name-unboundNameX where_look rdr_name extra-  = do  { dflags <- getDynFlags-        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags-              err = notInScopeErr rdr_name $$ extra-        ; if not show_helpful_errors-          then addErr err-          else do { local_env  <- getLocalRdrEnv-                  ; global_env <- getGlobalRdrEnv-                  ; impInfo <- getImports-                  ; currmod <- getModule-                  ; hpt <- getHpt-                  ; let suggestions = unknownNameSuggestions_ where_look-                          dflags hpt currmod global_env local_env impInfo-                          rdr_name-                  ; addErr (err $$ suggestions) }-        ; return (mkUnboundNameRdr rdr_name) }--notInScopeErr :: RdrName -> SDoc-notInScopeErr rdr_name-  = hang (text "Not in scope:")-       2 (what <+> quotes (ppr rdr_name))-  where-    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))--type HowInScope = Either SrcSpan ImpDeclSpec-     -- Left loc    =>  locally bound at loc-     -- Right ispec =>  imported as specified by ispec----- | Called from the typechecker (TcErrors) when we find an unbound variable-unknownNameSuggestions :: DynFlags-                       -> HomePackageTable -> Module-                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails-                       -> RdrName -> SDoc-unknownNameSuggestions = unknownNameSuggestions_ WL_Any--unknownNameSuggestions_ :: WhereLooking -> DynFlags-                       -> HomePackageTable -> Module-                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails-                       -> RdrName -> SDoc-unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env-                          imports tried_rdr_name =-    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$-    importSuggestions where_look global_env hpt-                      curr_mod imports tried_rdr_name $$-    extensionSuggestions tried_rdr_name---similarNameSuggestions :: WhereLooking -> DynFlags-                        -> GlobalRdrEnv -> LocalRdrEnv-                        -> RdrName -> SDoc-similarNameSuggestions where_look dflags global_env-                        local_env tried_rdr_name-  = case suggest of-      []  -> Outputable.empty-      [p] -> perhaps <+> pp_item p-      ps  -> sep [ perhaps <+> text "one of these:"-                 , nest 2 (pprWithCommas pp_item ps) ]-  where-    all_possibilities :: [(String, (RdrName, HowInScope))]-    all_possibilities-       =  [ (showPpr dflags r, (r, Left loc))-          | (r,loc) <- local_possibilities local_env ]-       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]--    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities-    perhaps = text "Perhaps you meant"--    pp_item :: (RdrName, HowInScope) -> SDoc-    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined-        where loc' = case loc of-                     UnhelpfulSpan l -> parens (ppr l)-                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))-    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported-                              parens (text "imported from" <+> ppr (is_mod is))--    pp_ns :: RdrName -> SDoc-    pp_ns rdr | ns /= tried_ns = pprNameSpace ns-              | otherwise      = Outputable.empty-      where ns = rdrNameSpace rdr--    tried_occ     = rdrNameOcc tried_rdr_name-    tried_is_sym  = isSymOcc tried_occ-    tried_ns      = occNameSpace tried_occ-    tried_is_qual = isQual tried_rdr_name--    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns-                           && isSymOcc occ == tried_is_sym-        -- Treat operator and non-operators as non-matching-        -- This heuristic avoids things like-        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)--    local_ok = case where_look of { WL_Any -> True-                                  ; WL_LocalOnly -> True-                                  ; _ -> False }-    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]-    local_possibilities env-      | tried_is_qual = []-      | not local_ok  = []-      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)-                        | name <- localRdrEnvElts env-                        , let occ = nameOccName name-                        , correct_name_space occ]--    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]-    global_possibilities global_env-      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))-                        | gre <- globalRdrEnvElts global_env-                        , isGreOk where_look gre-                        , let name = gre_name gre-                              occ  = nameOccName name-                        , correct_name_space occ-                        , (mod, how) <- qualsInScope gre-                        , let rdr_qual = mkRdrQual mod occ ]--      | otherwise = [ (rdr_unqual, pair)-                    | gre <- globalRdrEnvElts global_env-                    , isGreOk where_look gre-                    , let name = gre_name gre-                          occ  = nameOccName name-                          rdr_unqual = mkRdrUnqual occ-                    , correct_name_space occ-                    , pair <- case (unquals_in_scope gre, quals_only gre) of-                                (how:_, _)    -> [ (rdr_unqual, how) ]-                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]-                                ([],    [])   -> [] ]--              -- Note [Only-quals]-              -- The second alternative returns those names with the same-              -- OccName as the one we tried, but live in *qualified* imports-              -- e.g. if you have:-              ---              -- > import qualified Data.Map as Map-              -- > foo :: Map-              ---              -- then we suggest @Map.Map@.--    ---------------------    unquals_in_scope :: GlobalRdrElt -> [HowInScope]-    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })-      | lcl       = [ Left (nameSrcSpan n) ]-      | otherwise = [ Right ispec-                    | i <- is, let ispec = is_decl i-                    , not (is_qual ispec) ]---    ---------------------    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]-    -- Ones for which *only* the qualified version is in scope-    quals_only (GRE { gre_name = n, gre_imp = is })-      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)-        | i <- is, let ispec = is_decl i, is_qual ispec ]---- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.-importSuggestions :: WhereLooking-                  -> GlobalRdrEnv-                  -> HomePackageTable -> Module-                  -> ImportAvails -> RdrName -> SDoc-importSuggestions where_look global_env hpt currMod imports rdr_name-  | WL_LocalOnly <- where_look                 = Outputable.empty-  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty-  | null interesting_imports-  , Just name <- mod_name-  , show_not_imported_line name-  = hsep-      [ text "No module named"-      , quotes (ppr name)-      , text "is imported."-      ]-  | is_qualified-  , null helpful_imports-  , [(mod,_)] <- interesting_imports-  = hsep-      [ text "Module"-      , quotes (ppr mod)-      , text "does not export"-      , quotes (ppr occ_name) <> dot-      ]-  | is_qualified-  , null helpful_imports-  , not (null interesting_imports)-  , mods <- map fst interesting_imports-  = hsep-      [ text "Neither"-      , quotedListWithNor (map ppr mods)-      , text "exports"-      , quotes (ppr occ_name) <> dot-      ]-  | [(mod,imv)] <- helpful_imports_non_hiding-  = fsep-      [ text "Perhaps you want to add"-      , quotes (ppr occ_name)-      , text "to the import list"-      , text "in the import of"-      , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot-      ]-  | not (null helpful_imports_non_hiding)-  = fsep-      [ text "Perhaps you want to add"-      , quotes (ppr occ_name)-      , text "to one of these import lists:"-      ]-    $$-    nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))-        | (mod,imv) <- helpful_imports_non_hiding-        ])-  | [(mod,imv)] <- helpful_imports_hiding-  = fsep-      [ text "Perhaps you want to remove"-      , quotes (ppr occ_name)-      , text "from the explicit hiding list"-      , text "in the import of"-      , quotes (ppr mod)-      , parens (ppr (imv_span imv)) <> dot-      ]-  | not (null helpful_imports_hiding)-  = fsep-      [ text "Perhaps you want to remove"-      , quotes (ppr occ_name)-      , text "from the hiding clauses"-      , text "in one of these imports:"-      ]-    $$-    nest 2 (vcat-        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))-        | (mod,imv) <- helpful_imports_hiding-        ])-  | otherwise-  = Outputable.empty- where-  is_qualified = isQual rdr_name-  (mod_name, occ_name) = case rdr_name of-    Unqual occ_name        -> (Nothing, occ_name)-    Qual mod_name occ_name -> (Just mod_name, occ_name)-    _                      -> error "importSuggestions: dead code"---  -- What import statements provide "Mod" at all-  -- or, if this is an unqualified name, are not qualified imports-  interesting_imports = [ (mod, imp)-    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)-    , Just imp <- return $ pick (importedByUser mod_imports)-    ]--  -- We want to keep only one for each original module; preferably one with an-  -- explicit import list (for no particularly good reason)-  pick :: [ImportedModsVal] -> Maybe ImportedModsVal-  pick = listToMaybe . sortBy (compare `on` prefer) . filter select-    where select imv = case mod_name of Just name -> imv_name imv == name-                                        Nothing   -> not (imv_qualified imv)-          prefer imv = (imv_is_hiding imv, imv_span imv)--  -- Which of these would export a 'foo'-  -- (all of these are restricted imports, because if they were not, we-  -- wouldn't have an out-of-scope error in the first place)-  helpful_imports = filter helpful interesting_imports-    where helpful (_,imv)-            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name--  -- Which of these do that because of an explicit hiding list resp. an-  -- explicit import list-  (helpful_imports_hiding, helpful_imports_non_hiding)-    = partition (imv_is_hiding . snd) helpful_imports--  -- See note [When to show/hide the module-not-imported line]-  show_not_imported_line :: ModuleName -> Bool                    -- #15611-  show_not_imported_line modnam-      | modnam `elem` globMods                = False    -- #14225     -- 1-      | moduleName currMod == modnam          = False                  -- 2.1-      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2-      | otherwise                             = True-    where-      hpt_uniques = map fst (udfmToList hpt)-      is_last_loaded_mod _ []         = False-      is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam-      globMods = nub [ mod-                     | gre <- globalRdrEnvElts global_env-                     , isGreOk where_look gre-                     , (mod, _) <- qualsInScope gre-                     ]--extensionSuggestions :: RdrName -> SDoc-extensionSuggestions rdrName-  | rdrName == mkUnqual varName (fsLit "mdo") ||-    rdrName == mkUnqual varName (fsLit "rec")-      = text "Perhaps you meant to use RecursiveDo"-  | otherwise = Outputable.empty--qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]--- Ones for which the qualified version is in scope-qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }-      | lcl = case nameModule_maybe n of-                Nothing -> []-                Just m  -> [(moduleName m, Left (nameSrcSpan n))]-      | otherwise = [ (is_as ispec, Right ispec)-                    | i <- is, let ispec = is_decl i ]--isGreOk :: WhereLooking -> GlobalRdrElt -> Bool-isGreOk where_look = case where_look of-                         WL_LocalTop  -> isLocalGRE-                         WL_LocalOnly -> const False-                         _            -> const True--{- Note [When to show/hide the module-not-imported line]           -- #15611-For the error message:-    Not in scope X.Y-    Module X does not export Y-    No module named ‘X’ is imported:-there are 2 cases, where we hide the last "no module is imported" line:-1. If the module X has been imported.-2. If the module X is the current module. There are 2 subcases:-   2.1 If the unknown module name is in a input source file,-       then we can use the getModule function to get the current module name.-       (See test T15611a)-   2.2 If the unknown module name has been entered by the user in GHCi,-       then the getModule function returns something like "interactive:Ghci1",-       and we have to check the current module in the last added entry of-       the HomePackageTable. (See test T15611b)--}
− compiler/rename/RnUtils.hs 
@@ -1,514 +0,0 @@-{---This module contains miscellaneous functions related to renaming.---}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}--module RnUtils (-        checkDupRdrNames, checkShadowedRdrNames,-        checkDupNames, checkDupAndShadowedNames, dupNamesErr,-        checkTupSize,-        addFvRn, mapFvRn, mapMaybeFvRn,-        warnUnusedMatches, warnUnusedTypePatterns,-        warnUnusedTopBinds, warnUnusedLocalBinds,-        checkUnusedRecordWildcard,-        mkFieldEnv,-        unknownSubordinateErr, badQualBndrErr, typeAppErr,-        HsDocContext(..), pprHsDocContext,-        inHsDocContext, withHsDocContext,--        newLocalBndrRn, newLocalBndrsRn,--        bindLocalNames, bindLocalNamesFV,--        addNameClashErrRn, extendTyVarEnvFVRn--)--where---import GhcPrelude--import GHC.Hs-import RdrName-import HscTypes-import TcEnv-import TcRnMonad-import Name-import NameSet-import NameEnv-import DataCon-import SrcLoc-import Outputable-import Util-import BasicTypes       ( TopLevelFlag(..) )-import ListSetOps       ( removeDups )-import DynFlags-import FastString-import Control.Monad-import Data.List-import Constants        ( mAX_TUPLE_SIZE )-import qualified Data.List.NonEmpty as NE-import qualified GHC.LanguageExtensions as LangExt--{--*********************************************************-*                                                      *-\subsection{Binding}-*                                                      *-*********************************************************--}--newLocalBndrRn :: Located RdrName -> RnM Name--- Used for non-top-level binders.  These should--- never be qualified.-newLocalBndrRn (L loc rdr_name)-  | Just name <- isExact_maybe rdr_name-  = return name -- This happens in code generated by Template Haskell-                -- See Note [Binders in Template Haskell] in Convert.hs-  | otherwise-  = do { unless (isUnqual rdr_name)-                (addErrAt loc (badQualBndrErr rdr_name))-       ; uniq <- newUnique-       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }--newLocalBndrsRn :: [Located RdrName] -> RnM [Name]-newLocalBndrsRn = mapM newLocalBndrRn--bindLocalNames :: [Name] -> RnM a -> RnM a-bindLocalNames names enclosed_scope-  = do { lcl_env <- getLclEnv-       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)-             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)-                           [ (n, (NotTopLevel, th_level)) | n <- names ]-             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names-       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'-                            , tcl_rdr      = rdr_env' })-                    enclosed_scope }--bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)-bindLocalNamesFV names enclosed_scope-  = do  { (result, fvs) <- bindLocalNames names enclosed_scope-        ; return (result, delFVs names fvs) }-----------------------------------------extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)-extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside----------------------------------------checkDupRdrNames :: [Located RdrName] -> RnM ()--- Check for duplicated names in a binding group-checkDupRdrNames rdr_names_w_loc-  = mapM_ (dupNamesErr getLoc) dups-  where-    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc--checkDupNames :: [Name] -> RnM ()--- Check for duplicated names in a binding group-checkDupNames names = check_dup_names (filterOut isSystemName names)-                -- See Note [Binders in Template Haskell] in Convert--check_dup_names :: [Name] -> RnM ()-check_dup_names names-  = mapM_ (dupNamesErr nameSrcSpan) dups-  where-    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names------------------------checkShadowedRdrNames :: [Located RdrName] -> RnM ()-checkShadowedRdrNames loc_rdr_names-  = do { envs <- getRdrEnvs-       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }-  where-    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names-                -- See Note [Binders in Template Haskell] in Convert-    get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)--checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()-checkDupAndShadowedNames envs names-  = do { check_dup_names filtered_names-       ; checkShadowedOccs envs get_loc_occ filtered_names }-  where-    filtered_names = filterOut isSystemName names-                -- See Note [Binders in Template Haskell] in Convert-    get_loc_occ name = (nameSrcSpan name, nameOccName name)----------------------------------------checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)-                  -> (a -> (SrcSpan, OccName))-                  -> [a] -> RnM ()-checkShadowedOccs (global_env,local_env) get_loc_occ ns-  = whenWOptM Opt_WarnNameShadowing $-    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))-        ; mapM_ check_shadow ns }-  where-    check_shadow n-        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"-                                                -- See #3262-        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]-        | otherwise = do { gres' <- filterM is_shadowed_gre gres-                         ; complain (map pprNameProvenance gres') }-        where-          (loc,occ) = get_loc_occ n-          mb_local  = lookupLocalRdrOcc local_env occ-          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env-                -- Make an Unqualified RdrName and look that up, so that-                -- we don't find any GREs that are in scope qualified-only--          complain []      = return ()-          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)-                                       loc-                                       (shadowedNameWarn occ pp_locs)--    is_shadowed_gre :: GlobalRdrElt -> RnM Bool-        -- Returns False for record selectors that are shadowed, when-        -- punning or wild-cards are on (cf #2723)-    is_shadowed_gre gre | isRecFldGRE gre-        = do { dflags <- getDynFlags-             ; return $ not (xopt LangExt.RecordPuns dflags-                             || xopt LangExt.RecordWildCards dflags) }-    is_shadowed_gre _other = return True---{--************************************************************************-*                                                                      *-\subsection{Free variable manipulation}-*                                                                      *-************************************************************************--}---- A useful utility-addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)-addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside-                               ; return (res, fvs1 `plusFV` fvs2) }--mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)-mapFvRn f xs = do stuff <- mapM f xs-                  case unzip stuff of-                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)--mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)-mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)-mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }--{--************************************************************************-*                                                                      *-\subsection{Envt utility functions}-*                                                                      *-************************************************************************--}--warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()-warnUnusedTopBinds gres-    = whenWOptM Opt_WarnUnusedTopBinds-    $ do env <- getGblEnv-         let isBoot = tcg_src env == HsBootFile-         let noParent gre = case gre_par gre of-                            NoParent -> True-                            _        -> False-             -- Don't warn about unused bindings with parents in-             -- .hs-boot files, as you are sometimes required to give-             -- unused bindings (trac #3449).-             -- HOWEVER, in a signature file, you are never obligated to put a-             -- definition in the main text.  Thus, if you define something-             -- and forget to export it, we really DO want to warn.-             gres' = if isBoot then filter noParent gres-                               else                 gres-         warnUnusedGREs gres'----- | Checks to see if we need to warn for -Wunused-record-wildcards or--- -Wredundant-record-wildcards-checkUnusedRecordWildcard :: SrcSpan-                          -> FreeVars-                          -> Maybe [Name]-                          -> RnM ()-checkUnusedRecordWildcard _ _ Nothing    = return ()-checkUnusedRecordWildcard loc _ (Just [])  = do-  -- Add a new warning if the .. pattern binds no variables-  setSrcSpan loc $ warnRedundantRecordWildcard-checkUnusedRecordWildcard loc fvs (Just dotdot_names) =-  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs----- | Produce a warning when the `..` pattern binds no new--- variables.------ @---   data P = P { x :: Int }------   foo (P{x, ..}) = x--- @------ The `..` here doesn't bind any variables as `x` is already bound.-warnRedundantRecordWildcard :: RnM ()-warnRedundantRecordWildcard =-  whenWOptM Opt_WarnRedundantRecordWildcards-            (addWarn (Reason Opt_WarnRedundantRecordWildcards)-                     redundantWildcardWarning)----- | Produce a warning when no variables bound by a `..` pattern are used.------ @---   data P = P { x :: Int }------   foo (P{..}) = ()--- @------ The `..` pattern binds `x` but it is not used in the RHS so we issue--- a warning.-warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()-warnUnusedRecordWildcard ns used_names = do-  let used = filter (`elemNameSet` used_names) ns-  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)-  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)-    unusedRecordWildcardWarning----warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns-  :: [Name] -> FreeVars -> RnM ()-warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds-warnUnusedMatches      = check_unused Opt_WarnUnusedMatches-warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns--check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()-check_unused flag bound_names used_names-  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)-                                               bound_names))------------------------------      Helpers-warnUnusedGREs :: [GlobalRdrElt] -> RnM ()-warnUnusedGREs gres = mapM_ warnUnusedGRE gres--warnUnused :: WarningFlag -> [Name] -> RnM ()-warnUnused flag names = do-    fld_env <- mkFieldEnv <$> getGlobalRdrEnv-    mapM_ (warnUnused1 flag fld_env) names--warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()-warnUnused1 flag fld_env name-  = when (reportable name occ) $-    addUnusedWarning flag-                     occ (nameSrcSpan name)-                     (text $ "Defined but not used" ++ opt_str)-  where-    occ = case lookupNameEnv fld_env name of-              Just (fl, _) -> mkVarOccFS fl-              Nothing      -> nameOccName name-    opt_str = case flag of-                Opt_WarnUnusedTypePatterns -> " on the right hand side"-                _ -> ""--warnUnusedGRE :: GlobalRdrElt -> RnM ()-warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })-  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv-                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name-  | otherwise = when (reportable name occ) (mapM_ warn is)-  where-    occ = greOccName gre-    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg-        where-           span = importSpecLoc spec-           pp_mod = quotes (ppr (importSpecModule spec))-           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")---- | Make a map from selector names to field labels and parent tycon--- names, to be used when reporting unused record fields.-mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)-mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))-                               | gres <- occEnvElts rdr_env-                               , gre <- gres-                               , Just lbl <- [greLabel gre]-                               ]---- | Should we report the fact that this 'Name' is unused? The--- 'OccName' may differ from 'nameOccName' due to--- DuplicateRecordFields.-reportable :: Name -> OccName -> Bool-reportable name occ-  | isWiredInName name = False    -- Don't report unused wired-in names-                                  -- Otherwise we get a zillion warnings-                                  -- from Data.Tuple-  | otherwise = not (startsWithUnderscore occ)--addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()-addUnusedWarning flag occ span msg-  = addWarnAt (Reason flag) span $-    sep [msg <> colon,-         nest 2 $ pprNonVarNameSpace (occNameSpace occ)-                        <+> quotes (ppr occ)]--unusedRecordWildcardWarning :: SDoc-unusedRecordWildcardWarning =-  wildcardDoc $ text "No variables bound in the record wildcard match are used"--redundantWildcardWarning :: SDoc-redundantWildcardWarning =-  wildcardDoc $ text "Record wildcard does not bind any new variables"--wildcardDoc :: SDoc -> SDoc-wildcardDoc herald =-  herald-    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"-                                            <+> quotes (text ".."))--addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()-addNameClashErrRn rdr_name gres-  | all isLocalGRE gres && not (all isRecFldGRE gres)-               -- If there are two or more *local* defns, we'll have reported-  = return ()  -- that already, and we don't want an error cascade-  | otherwise-  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)-                 , text "It could refer to"-                 , nest 3 (vcat (msg1 : msgs)) ])-  where-    (np1:nps) = gres-    msg1 =  text "either" <+> ppr_gre np1-    msgs = [text "    or" <+> ppr_gre np | np <- nps]-    ppr_gre gre = sep [ pp_gre_name gre <> comma-                      , pprNameProvenance gre]--    -- When printing the name, take care to qualify it in the same-    -- way as the provenance reported by pprNameProvenance, namely-    -- the head of 'gre_imp'.  Otherwise we get confusing reports like-    --   Ambiguous occurrence ‘null’-    --   It could refer to either ‘T15487a.null’,-    --                            imported from ‘Prelude’ at T15487.hs:1:8-13-    --                     or ...-    -- See #15487-    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent-                         , gre_lcl = lcl, gre_imp = iss })-      | FldParent { par_lbl = Just lbl } <- parent-      = text "the field" <+> quotes (ppr lbl)-      | otherwise-      = quotes (pp_qual <> dot <> ppr (nameOccName name))-      where-        pp_qual | lcl-                = ppr (nameModule name)-                | imp : _ <- iss  -- This 'imp' is the one that-                                  -- pprNameProvenance chooses-                , ImpDeclSpec { is_as = mod } <- is_decl imp-                = ppr mod-                | otherwise-                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)-                  -- Invariant: either 'lcl' is True or 'iss' is non-empty--shadowedNameWarn :: OccName -> [SDoc] -> SDoc-shadowedNameWarn occ shadowed_locs-  = sep [text "This binding for" <+> quotes (ppr occ)-            <+> text "shadows the existing binding" <> plural shadowed_locs,-         nest 2 (vcat shadowed_locs)]---unknownSubordinateErr :: SDoc -> RdrName -> SDoc-unknownSubordinateErr doc op    -- Doc is "method of class" or-                                -- "field of constructor"-  = quotes (ppr op) <+> text "is not a (visible)" <+> doc---dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()-dupNamesErr get_loc names-  = addErrAt big_loc $-    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),-          locations]-  where-    locs      = map get_loc (NE.toList names)-    big_loc   = foldr1 combineSrcSpans locs-    locations = text "Bound at:" <+> vcat (map ppr (sort locs))--badQualBndrErr :: RdrName -> SDoc-badQualBndrErr rdr_name-  = text "Qualified name in binding position:" <+> ppr rdr_name--typeAppErr :: String -> LHsType GhcPs -> SDoc-typeAppErr what (L _ k)-  = hang (text "Illegal visible" <+> text what <+> text "application"-            <+> quotes (char '@' <> ppr k))-       2 (text "Perhaps you intended to use TypeApplications")--checkTupSize :: Int -> RnM ()-checkTupSize tup_size-  | tup_size <= mAX_TUPLE_SIZE-  = return ()-  | otherwise-  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),-                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),-                 nest 2 (text "Workaround: use nested tuples or define a data type")])---{--************************************************************************-*                                                                      *-\subsection{Contexts for renaming errors}-*                                                                      *-************************************************************************--}---- AZ:TODO: Change these all to be Name instead of RdrName.---          Merge TcType.UserTypeContext in to it.-data HsDocContext-  = TypeSigCtx SDoc-  | StandaloneKindSigCtx SDoc-  | PatCtx-  | SpecInstSigCtx-  | DefaultDeclCtx-  | ForeignDeclCtx (Located RdrName)-  | DerivDeclCtx-  | RuleCtx FastString-  | TyDataCtx (Located RdrName)-  | TySynCtx (Located RdrName)-  | TyFamilyCtx (Located RdrName)-  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance-  | ConDeclCtx [Located Name]-  | ClassDeclCtx (Located RdrName)-  | ExprWithTySigCtx-  | TypBrCtx-  | HsTypeCtx-  | GHCiCtx-  | SpliceTypeCtx (LHsType GhcPs)-  | ClassInstanceCtx-  | GenericCtx SDoc   -- Maybe we want to use this more!--withHsDocContext :: HsDocContext -> SDoc -> SDoc-withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt--inHsDocContext :: HsDocContext -> SDoc-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt--pprHsDocContext :: HsDocContext -> SDoc-pprHsDocContext (GenericCtx doc)      = doc-pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc-pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc-pprHsDocContext PatCtx                = text "a pattern type-signature"-pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"-pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"-pprHsDocContext DerivDeclCtx          = text "a deriving declaration"-pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name-pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)-pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)-pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)-pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)-pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)-pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"-pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"-pprHsDocContext HsTypeCtx             = text "a type argument"-pprHsDocContext GHCiCtx               = text "GHCi input"-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)-pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"--pprHsDocContext (ForeignDeclCtx name)-   = text "the foreign declaration for" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx [name])-   = text "the definition of data constructor" <+> quotes (ppr name)-pprHsDocContext (ConDeclCtx names)-   = text "the definition of data constructors" <+> interpp'SP names
compiler/simplCore/CSE.hs view
@@ -6,6 +6,9 @@  {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ module CSE (cseProgram, cseOneExpr) where  #include "HsVersions.h"@@ -500,7 +503,7 @@ Now there is terrible danger that, in an importing module, we'll inline 'g' before we have a chance to run its specialisation! -Solution: during CSE, afer a "hit" in the CSE cache+Solution: during CSE, after a "hit" in the CSE cache   * when adding a binding         g = f   * for a top-level function g@@ -540,7 +543,7 @@      flatten_ty_con_app = \x y. let <stuff> in \z. blah * That allowed the float-out pass to put sguff between   the \y and \z.-* And that permanently stopped eta expasion of the function,+* And that permanently stopped eta expansion of the function,   even once <stuff> was simplified.  -}@@ -667,7 +670,7 @@ alternative.  It seems like the same kind of thing that CSE is supposed to be doing, which is why I put it here. -I acutally saw some examples in the wild, where some inlining made e1 too+I actually saw some examples in the wild, where some inlining made e1 too big for cheapEqExpr to catch it.
compiler/simplCore/Exitify.hs view
@@ -227,7 +227,7 @@            ; return $ mkVarApps (Var v) abs_vars }        where-        -- Used to detect exit expressoins that are already proper exit jumps+        -- Used to detect exit expressions that are already proper exit jumps         isCapturedVarArg (Var v) = v `elem` captured         isCapturedVarArg _ = False
compiler/simplCore/FloatIn.hs view
@@ -14,6 +14,7 @@  {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fprof-auto #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module FloatIn ( floatInwards ) where
compiler/simplCore/FloatOut.hs view
@@ -529,7 +529,7 @@  We used instead to do the partitionByMajorLevel on the RHS of an '=', in floatRhs.  But that was quite tiresome.  We needed to test for-values or trival rhss, because (in particular) we don't want to insert+values or trivial rhss, because (in particular) we don't want to insert new bindings between the "=" and the "\".  E.g.         f = \x -> let <bind> in <body> We do not want
compiler/simplCore/LiberateCase.hs view
@@ -164,7 +164,7 @@ {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do not specialise error-functions (this is unusual, but I once saw it,-(acually in Data.Typable.Internal)+(actually in Data.Typable.Internal)  Note [Only functions!] ~~~~~~~~~~~~~~~~~~~~~~
compiler/simplCore/SetLevels.hs view
@@ -50,6 +50,8 @@ -}  {-# LANGUAGE CPP, MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module SetLevels (         setLevels, @@ -554,7 +556,7 @@       {- some expression involving x and z -}  When analysing <body involving...> we want to use the /ambient/ level,-and /not/ the desitnation level of the 'case a of (x,-) ->' binding.+and /not/ the destination level of the 'case a of (x,-) ->' binding.  #16978 was caused by us setting the context level to the destination level of `x` when analysing <body>. This led us to conclude that we@@ -792,7 +794,7 @@   f x = j x 0  and now there is a chance that 'f' will be inlined at its call sites.-It shouldn't make a lot of difference, but thes tests+It shouldn't make a lot of difference, but these tests   perf/should_run/MethSharing   simplCore/should_compile/spec-inline and one nofib program, all improve if you do float to top, because@@ -800,7 +802,7 @@  Note [Free join points] ~~~~~~~~~~~~~~~~~~~~~~~-We never float a MFE that has a free join-point variable.  You mght think+We never float a MFE that has a free join-point variable.  You might think this can never occur.  After all, consider      join j x = ...      in ....(jump j x)....
compiler/simplCore/SimplCore.hs view
@@ -743,7 +743,9 @@                 -- Loop            do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1            } }+#if __GLASGOW_HASKELL__ <= 810       | otherwise = panic "do_iteration"+#endif       where         (us1, us2) = splitUniqSupply us @@ -881,7 +883,7 @@ By the time we've thrown away the types in STG land this could be eliminated.  But I don't think it's very common and it's dangerous to do this fiddling in STG land-because we might elminate a binding that's mentioned in the+because we might eliminate a binding that's mentioned in the unfolding for something.  Note [Indirection zapping and ticks]
compiler/simplCore/SimplEnv.hs view
@@ -372,7 +372,7 @@ - Then that continuation gets pushed under the let  - Finally we simplify 'arg'.  We want-     - the static, lexical environment bindig x :-> x1+     - the static, lexical environment binding x :-> x1      - the in-scopeset from "here", under the 'let' which includes        both x1 and x2
compiler/simplCore/SimplUtils.hs view
@@ -549,7 +549,7 @@    {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} -If we expose zip's bottoming nature when simplifing the LHS of the+If we expose zip's bottoming nature when simplifying the LHS of the RULE we get   {-# RULES "foo" forall as bs.                    stream (case zip of {}) = ..blah... #-}@@ -1053,7 +1053,7 @@ and inline it unconditionally.  But suppose x is used many times, but this is the unique occurrence of y.  Then inlining x would change y's occurrence info, which breaks the invariant.  It matters: y-might have a BIG rhs, which will now be dup'd at every occurrenc of x.+might have a BIG rhs, which will now be dup'd at every occurrence of x.   Even RHSs labelled InlineMe aren't caught here, because there might be@@ -1236,7 +1236,7 @@ site right now, and we'll get another opportunity when we get to the occurrence(s) -Note that we do this unconditional inlining only for trival RHSs.+Note that we do this unconditional inlining only for trivial RHSs. Don't inline even WHNFs inside lambdas; doing so may simply increase allocation when the function is called. This isn't the last chance; see NOTE above.@@ -1322,7 +1322,7 @@ --      in \y. ....case f of {...} .... -- Here f is used just once, and duplicating the case work is fine (exprIsCheap). -- But---  - We can't preInlineUnconditionally because that woud invalidate+--  - We can't preInlineUnconditionally because that would invalidate --    the occ info for b. --  - We can't postInlineUnconditionally because the RHS is big, and --    that risks exponential behaviour@@ -1626,7 +1626,7 @@  But there is really no point in doing this, and it generates masses of coercions and whatnot that eventually disappear again. For T9020, GHC-allocated 6.6G beore, and 0.8G afterwards; and residency dropped from+allocated 6.6G before, and 0.8G afterwards; and residency dropped from 1.8G to 45M.  But note that this won't eta-expand, say@@ -2234,7 +2234,7 @@  This may generate sligthtly better code (although it should not, since all cases are exhaustive) and/or optimise better.  I'm not certain that-it's necessary, but currenty we do make this change.  We do it here,+it's necessary, but currently we do make this change.  We do it here, NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] in PrelRules) -}@@ -2315,7 +2315,7 @@     0 -> ...     DEFAULT -> case a1 of ... -This is corect, but we can't do a case merge in this sweep+This is correct, but we can't do a case merge in this sweep because c2 /= a1.  Reason: the binding c1=I# a1 went inwards without getting changed to c1=I# c2.
compiler/simplCore/Simplify.hs view
@@ -6,6 +6,7 @@  {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Simplify ( simplTopBinds, simplExpr, simplRules ) where  #include "HsVersions.h"@@ -1712,8 +1713,8 @@              C -> e) of <outer-alts>  This would be OK in the language of the paper, but not in GHC: j is no longer-a join point.  We can only do the "push contination into the RHS of the-join point j" if we also push the contination right down to the /jumps/ to+a join point.  We can only do the "push continuation into the RHS of the+join point j" if we also push the continuation right down to the /jumps/ to j, so that it can evaporate there.  If we are doing case-of-case, we'll get to      join x = case <j-rhs> of <outer-alts> in@@ -2264,7 +2265,7 @@            True  -> r            False -> r -Now again the case may be elminated by the CaseElim transformation.+Now again the case may be eliminated by the CaseElim transformation. This includes things like (==# a# b#)::Bool so that we simplify       case ==# a# b# of { True -> x; False -> x } to just@@ -3501,7 +3502,7 @@     return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)             -- We make an  unfolding *even for loop-breakers*.             -- Reason: (a) It might be useful to know that they are WHNF-            --         (b) In TidyPgm we currently assume that, if we want to+            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to             --             expose the unfolding then indeed we *have* an unfolding             --             to expose.  (We could instead use the RHS, but currently             --             we don't.)  The simple thing is always to have one.
compiler/specialise/SpecConstr.hs view
@@ -12,6 +12,8 @@  {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module SpecConstr(         specConstrProgram,         SpecConstrAnnotation(..)@@ -791,7 +793,7 @@  Not good!  We build an (I# x) box every time around the loop. SpecConstr (as described in the paper) does not specialise f, despite-the call (f ... (I# x)) because 'y' is not scrutinied in the body.+the call (f ... (I# x)) because 'y' is not scrutinised in the body. But it is much better to specialise f for the case where the argument is of form (I# x); then we build the box only when returning y, which is on the cold path.@@ -804,7 +806,7 @@ then the call (g x) might allow 'g' to be specialised in turn.  So sc_keen controls whether or not we take account of whether argument is-scrutinised in the body.  True <=> ignore that, and speicalise whenever+scrutinised in the body.  True <=> ignore that, and specialise whenever the function is applied to a data constructor. -} @@ -1164,7 +1166,7 @@ evalScrutOcc :: ArgOcc evalScrutOcc = ScrutOcc emptyUFM --- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so+-- Experimentally, this version of combineOcc makes ScrutOcc "win", so -- that if the thing is scrutinised anywhere then we get to see that -- in the overall result, even if it's also used in a boxed way -- This might be too aggressive; see Note [Reboxing] Alternative 3@@ -1934,7 +1936,7 @@    co :: Foo ~R (Int,Int)  Here we definitely do want to specialise for that pair!  We do not-match on the structre of the coercion; instead we just match on a+match on the structure of the coercion; instead we just match on a coercion variable, so the RULE looks like     forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)
compiler/specialise/Specialise.hs view
@@ -7,6 +7,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Specialise ( specProgram, specUnfolding ) where  #include "HsVersions.h"@@ -199,7 +201,7 @@ Further notes on (b)  * There are quite a few variations here.  For example, the defn of-  +.sel could be floated ouside the \y, to attempt to gain laziness.+  +.sel could be floated outside the \y, to attempt to gain laziness.   It certainly mustn't be floated outside the \d because the d has to   be in scope too. @@ -2158,7 +2160,7 @@   = ppr fn <+> ppr key  ppr_call_key_ty :: SpecArg -> Maybe SDoc-ppr_call_key_ty (SpecType ty) = Just $ char '@' <+> pprParendType ty+ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty ppr_call_key_ty UnspecType    = Just $ char '_' ppr_call_key_ty (SpecDict _)  = Nothing ppr_call_key_ty UnspecArg     = Nothing
compiler/stranal/DmdAnal.hs view
@@ -53,7 +53,7 @@   = do {         let { binds_plus_dmds = do_prog binds } ;         dumpIfSet_dyn dflags Opt_D_dump_str_signatures-            "Strictness signatures" FormatSTG+            "Strictness signatures" FormatText             (dumpStrSig binds_plus_dmds) ;         -- See Note [Stamp out space leaks in demand analysis]         seqBinds binds_plus_dmds `seq` return binds_plus_dmds@@ -140,7 +140,7 @@ -- See ↦* relation in the Cardinality Analysis paper dmdAnalStar :: AnalEnv             -> Demand   -- This one takes a *Demand*-            -> CoreExpr -- Should obey the let/app invariatn+            -> CoreExpr -- Should obey the let/app invariant             -> (BothDmdArg, CoreExpr) dmdAnalStar env dmd e   | (dmd_shell, cd) <- toCleanDmd dmd@@ -333,7 +333,10 @@   | (bndr:_) <- bndrs   , con == tupleDataCon Unboxed 2   , idType bndr `eqType` realWorldStatePrimTy-  = not (exprOkForSpeculation scrut)+  , (fun, _) <- collectArgs scrut+  = case fun of+      Var f -> not (isPrimOpId f)+      _     -> True   | otherwise   = False @@ -384,18 +387,15 @@ situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle (on an MVar not an Int), and made a material difference. -So if the scrutinee is ok-for-speculation, we *don't* apply the state hack,-because we are free to push evaluation of the scrutinee after evaluation of-expressions from the (single) case alternative.--A few examples for different scrutinees:+So if the scrutinee is a primop call, we *don't* apply the+state hack:   - If it is a simple, terminating one like getMaskingState,-    applying the hack would be over-conservative.-  - If the primop is raise# then it returns bottom (so not ok-for-speculation),-    but the result from the case alternatives are discarded anyway.+    applying the hack is over-conservative.+  - If the primop is raise# then it returns bottom, so+    the case alternatives are already discarded.   - If the primop can raise a non-IO exception, like-    divide by zero (so not ok-for-speculation), then we are also bottoming out-    anyway and don't mind evaluating 'x' first.+    divide by zero or seg-fault (eg writing an array+    out of bounds) then we don't mind evaluating 'x' first.  Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -501,7 +501,7 @@        -> AnalEnv                            -- Does not include bindings for this binding        -> CleanDemand        -> [(Id,CoreExpr)]-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info  dmdFix top_lvl env let_dmd orig_pairs   = loop 1 initial_pairs
compiler/stranal/WwLib.hs view
@@ -209,7 +209,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~ At one time we refrained from doing CPR w/w for thunks, on the grounds that we might duplicate work.  But that is already handled by the demand analyser,-which doesn't give the CPR proprety if w/w might waste work: see+which doesn't give the CPR property if w/w might waste work: see Note [CPR for thunks] in DmdAnal.  And if something *has* been given the CPR property and we don't w/w, it's
compiler/typecheck/ClsInst.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module ClsInst (      matchGlobalInst,      ClsInstResult(..),@@ -18,7 +20,7 @@ import TcMType import TcEvidence import Predicate-import RnEnv( addUsedGRE )+import GHC.Rename.Env( addUsedGRE ) import RdrName( lookupGRE_FieldLabel ) import InstEnv import Inst( instDFunType )@@ -60,7 +62,7 @@                                             -- Why scoped?  See bind_me in                                             -- TcValidity.checkConsistentFamInst               , ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types-                -- See Note [Matching in the consistent-instantation check]+                -- See Note [Matching in the consistent-instantiation check]     }  isNotAssociated :: AssocInstInfo -> Bool
compiler/typecheck/FamInst.hs view
@@ -21,7 +21,7 @@ import Coercion import CoreLint import TcEvidence-import LoadIface+import GHC.Iface.Load import TcRnMonad import SrcLoc import TyCon@@ -142,7 +142,7 @@ * The call to checkFamConsistency for imported functions occurs very   early (in tcRnImports) and that causes problems if the imported   instances use type declared in the module being compiled.-  See Note [Loading your own hi-boot file] in LoadIface.+  See Note [Loading your own hi-boot file] in GHC.Iface.Load. -}  {-@@ -1042,7 +1042,7 @@                , let ax = famInstAxiom fi ])  where    getSpan = getSrcLoc . famInstAxiom-   -- The sortWith just arranges that instances are dislayed in order+   -- The sortWith just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users
compiler/typecheck/FunDeps.hs view
@@ -321,7 +321,7 @@                         --                         -- But note (a) we get them from the dfun_id, so they are *in order*                         --              because the kind variables may be mentioned in the-                        --              type variabes' kinds+                        --              type variables' kinds                         --          (b) we must apply 'subst' to the kinds, in case we have                         --              matched out a kind variable, but not a type variable                         --              whose kind mentions that kind variable!@@ -606,7 +606,7 @@ In checkFunDeps we check that a new ClsInst is consistent with all the ClsInsts in the environment. -The bogus aspect is discussed in #10675. Currenty it if the two+The bogus aspect is discussed in #10675. Currently it if the two types are *contradicatory*, using (isNothing . tcUnifyTys).  But all the papers say we should check if the two types are *equal* thus    not (substTys subst rtys1 `eqTypes` substTys subst rtys2)
compiler/typecheck/Inst.hs view
@@ -9,6 +9,9 @@ {-# LANGUAGE CPP, MultiWayIf, TupleSections #-} {-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module Inst (        deeplySkolemise,        topInstantiate, topInstantiateInferred, deeplyInstantiate,@@ -262,7 +265,7 @@                    -> TCvSubst                    -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- Internal function to deeply instantiate that builds on an existing subst.--- It extends the input substitution and applies the final subtitution to+-- It extends the input substitution and applies the final substitution to -- the types on return.  See #12549.  deeply_instantiate orig subst ty@@ -842,6 +845,6 @@     addErr (hang herald 2 (pprInstances sorted))  where    sorted = sortWith getSrcLoc ispecs-   -- The sortWith just arranges that instances are dislayed in order+   -- The sortWith just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users
compiler/typecheck/TcArrows.hs view
@@ -8,6 +8,8 @@ {-# LANGUAGE RankNTypes, TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcArrows ( tcProc ) where  import GhcPrelude
compiler/typecheck/TcBackpack.hs view
@@ -30,14 +30,14 @@ import InstEnv import FamInstEnv import Inst-import TcIface+import GHC.IfaceToCore import TcMType import TcType import TcSimplify import Constraint import TcOrigin-import LoadIface-import RnNames+import GHC.Iface.Load+import GHC.Rename.Names import ErrUtils import Id import Module@@ -50,11 +50,11 @@ import Outputable import Type import FastString-import RnFixity ( lookupFixityRn )+import GHC.Rename.Fixity ( lookupFixityRn ) import Maybes import TcEnv import Var-import IfaceSyn+import GHC.Iface.Syntax import PrelNames import qualified Data.Map as Map @@ -63,7 +63,7 @@ import NameShape import TcErrors import TcUnify-import RnModIface+import GHC.Iface.Rename import Util  import Control.Monad@@ -462,7 +462,7 @@ --    to 'Name's, so this case needs to be handled specially. -- --    The details are in the documentation for 'typecheckIfacesForMerging'.---    and the Note [Resolving never-exported Names in TcIface].+--    and the Note [Resolving never-exported Names] in GHC.IfaceToCore. -- --  * When we rename modules and signatures, we use the export lists to --    decide how the declarations should be renamed.  However, this@@ -471,7 +471,7 @@ --    *consistently*, so that 'typecheckIfacesForMerging' can wire them --    up as needed. -----    The details are in Note [rnIfaceNeverExported] in 'RnModIface'.+--    The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'. -- -- The root cause for all of these complications is the fact that these -- logically "implicit" entities are defined indirectly in an interface@@ -687,7 +687,7 @@         --     final test of the export list.)         tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,         -- Inherit imports from the local signature, so that module-        -- rexports are picked up correctly+        -- reexports are picked up correctly         tcg_imports = tcg_imports orig_tcg_env,         tcg_exports = exports,         tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),@@ -859,7 +859,7 @@     -- when we have a ClsInst, we can pull up the correct DFun to check if     -- the types match.     ---    -- See also Note [rnIfaceNeverExported] in RnModIface+    -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename     dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do         n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))         let dfun = setVarName (is_dfun inst) n
compiler/typecheck/TcBinds.hs view
@@ -144,7 +144,7 @@  Etc. -NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),+NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...), which would make the space leak go away in this case  Solution: when typechecking the RHSs we always have in hand the@@ -355,7 +355,7 @@     tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"     tc_ip_bind _ (XIPBind nec) = noExtCon nec -    -- Coerces a `t` into a dictionry for `IP "x" t`.+    -- Coerces a `t` into a dictionary for `IP "x" t`.     -- co : t -> IP "x" t     toDict ipClass x ty = mkHsWrap $ mkWpCastR $                           wrapIP $ mkClassPred ipClass [x,ty]@@ -399,7 +399,7 @@             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do                    { thing <- thing_inside                      -- See Note [Pattern synonym builders don't yield dependencies]-                     --     in RnBinds+                     --     in GHC.Rename.Binds                    ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns                    ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]                    ; return (extra_binds, thing) }@@ -414,7 +414,7 @@              -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing) -- Typecheck a whole lot of value bindings, -- one strongly-connected component at a time--- Here a "strongly connected component" has the strightforward+-- Here a "strongly connected component" has the straightforward -- meaning of a group of bindings that mention each other, -- ignoring type signatures (that part comes later) @@ -1146,7 +1146,7 @@   f x y = [x, y]  We want to get an error from this, because 'a' and 'b' get unified.-So we make a test, one per parital signature, to check that the+So we make a test, one per partial signature, to check that the explicitly-quantified type variables have not been unified together. #14449 showed this up. @@ -1544,7 +1544,7 @@          Success => There was a type signature, so just use it,                     checking compatibility with the expected type. -         Failure => No type sigature.+         Failure => No type signature.              Infer case: (happens only outside any constructor pattern)                          use a unification variable                          at the outer level pc_lvl@@ -1634,7 +1634,7 @@       = [ null theta         | TcIdSig (PartialSig { psig_hs_ty = hs_ty })             <- mapMaybe sig_fn (collectHsBindListBinders lbinds)-        , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]+        , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]      has_partial_sigs   = not (null partial_sig_mrs)
compiler/typecheck/TcCanonical.hs view
@@ -279,7 +279,7 @@    superclasses for canonical CDictCans in solveSimpleGivens or    solveSimpleWanteds; Note [Danger of adding superclasses during solving] -   However, /do/ continue to eagerly expand superlasses for new /given/+   However, /do/ continue to eagerly expand superclasses for new /given/    /non-canonical/ constraints (canClassNC does this).  As #12175    showed, a type-family application can expand to a class constraint,    and we want to see its superclasses for just the same reason as@@ -543,6 +543,19 @@       = do { sc_ev <- newDerivedNC loc sc_pred            ; mk_superclasses rec_clss sc_ev [] [] sc_pred } +{- Note [Improvement from Ground Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose class C b a => D a b+and consider+  [W] D Int Bool+Is there any point in emitting [D] C Bool Int?  No!  The only point of+emitting superclass constraints for W/D constraints is to get+improvement, extra unifications that result from functional+dependencies.  See Note [Why adding superclasses can help] above.++But no variables means no improvement; case closed.+-}+ mk_superclasses :: NameSet -> CtEvidence                 -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] -- Return this constraint, plus its superclasses, if any@@ -605,7 +618,7 @@   f :: (forall a. a~b) => stuff  Now, potentially, the superclass machinery kicks in, in-makeSuperClasses, giving us a a second quantified constrait+makeSuperClasses, giving us a a second quantified constraint        (forall a. a ~# b) BUT this is an unboxed value!  And nothing has prepared us for dictionary "functions" that are unboxed.  Actually it does just@@ -687,11 +700,11 @@     Notice the 'm' in the head of the quantified constraint, not     a class. - 2. We suport superclasses to quantified constraints.+ 2. We support superclasses to quantified constraints.     For example (contrived):       f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool       f x y = x==y-    Here we need (Eq (m a)); but the quantifed constraint deals only+    Here we need (Eq (m a)); but the quantified constraint deals only     with Ord.  But we can make it work by using its superclass.  Here are the moving parts@@ -2295,7 +2308,7 @@                              , ctev_nosh = si                              , ctev_loc = loc }) new_pred co   = do { mb_new_ev <- newWanted_SI si loc new_pred-               -- The "_SI" varant ensures that we make a new Wanted+               -- The "_SI" variant ensures that we make a new Wanted                -- with the same shadow-info as the existing one                -- with the same shadow-info as the existing one (#16735)        ; MASSERT( tcCoercionRole co == ctEvRole ev )@@ -2347,7 +2360,7 @@    | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev   = do { (new_ev, hole_co) <- newWantedEq_SI si loc' (ctEvRole old_ev) nlhs nrhs-               -- The "_SI" varant ensures that we make a new Wanted+               -- The "_SI" variant ensures that we make a new Wanted                -- with the same shadow-info as the existing one (#16735)        ; let co = maybeSym swapped $                   mkSymCo lhs_co@@ -2357,8 +2370,10 @@        ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])        ; return new_ev } +#if __GLASGOW_HASKELL__ <= 810   | otherwise   = panic "rewriteEvidence"+#endif   where     new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
compiler/typecheck/TcClassDcl.hs view
@@ -9,6 +9,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcClassDcl ( tcClassSigs, tcClassDecl2,                     findMethodBind, instantiateMethod,                     tcClassMinimalDef,@@ -226,7 +228,7 @@           (sel_id, Just (dm_name, dm_spec))   | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn   = do { -- First look up the default method; it should be there!-         -- It can be the orinary default method+         -- It can be the ordinary default method          -- or the generic-default method.  E.g of the latter          --      class C a where          --        op :: a -> a -> Bool
compiler/typecheck/TcDeriv.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcDeriv ( tcDeriving, DerivInfo(..) ) where  #include "HsVersions.h"@@ -37,11 +39,11 @@ import TyCoRep import TyCoPpr    ( pprTyVars ) -import RnNames( extendGlobalRdrEnvRn )-import RnBinds-import RnEnv-import RnUtils    ( bindLocalNamesFV )-import RnSource   ( addTcgDUs )+import GHC.Rename.Names  ( extendGlobalRdrEnvRn )+import GHC.Rename.Binds+import GHC.Rename.Env+import GHC.Rename.Utils  ( bindLocalNamesFV )+import GHC.Rename.Source ( addTcgDUs ) import Avail  import Unify( tcUnifyTy )@@ -551,7 +553,7 @@  To address both of these problems, GHC now uses this algorithm instead: -1. Typecheck the `via` type and bring its boudn type variables into scope.+1. Typecheck the `via` type and bring its bound type variables into scope. 2. Take the first class in the `deriving` clause. 3. Typecheck the class. 4. Move on to the next class and repeat the process until all classes have been@@ -717,7 +719,7 @@ tcStandaloneDerivInstType ctxt     (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars                                        , hsib_body   = deriv_ty_body })})-  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body+  | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body   , L _ [wc_pred] <- theta   , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred   = do dfun_ty <- tcHsClsInstType ctxt $
compiler/typecheck/TcDerivInfer.hs view
@@ -948,7 +948,7 @@ unification variable across multiple iterations, then bad things can happen, such as #14933. -Similarly for 'baz', givng the constraint C2+Similarly for 'baz', giving the constraint C2     forall[2]. Eq (Maybe s) => (Ord a, Show a,                               Maybe s -> Maybe s -> Bool
compiler/typecheck/TcDerivUtils.hs view
@@ -35,8 +35,8 @@ import GHC.Hs import Inst import InstEnv-import LoadIface (loadInterfaceForName)-import Module (getModule)+import GHC.Iface.Load (loadInterfaceForName)+import Module         (getModule) import Name import Outputable import PrelNames@@ -644,7 +644,7 @@ -- If the TyCon is locally defined, we want the local fixity env; -- but if it is imported (which happens for standalone deriving) -- we need to get the fixity env from the interface file--- c.f. RnEnv.lookupFixity, and #9830+-- c.f. GHC.Rename.Env.lookupFixity, and #9830 getDataConFixityFun tc   = do { this_mod <- getModule        ; if nameIsLocalOrFrom this_mod name
compiler/typecheck/TcEnv.hs view
@@ -74,11 +74,11 @@ import GhcPrelude  import GHC.Hs-import IfaceEnv+import GHC.Iface.Env import TcRnMonad import TcMType import TcType-import LoadIface+import GHC.Iface.Load import PrelNames import TysWiredIn import Id@@ -209,7 +209,7 @@   tcLookupLocatedGlobal :: Located Name -> TcM TyThing--- c.f. IfaceEnvEnv.tcIfaceGlobal+-- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name   = addLocM tcLookupGlobal name @@ -508,7 +508,7 @@ isTypeClosedLetBndr = noFreeVarsOfType . idType  tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a--- Used for binding the recurive uses of Ids in a binding+-- Used for binding the recursive uses of Ids in a binding -- both top-level value bindings and nested let/where-bindings -- Does not extend the TcBinderStack tcExtendRecIds pairs thing_inside@@ -819,7 +819,7 @@ -- E.g. this is bad: --      x = [| foo |] --      $( f x )--- By the time we are prcessing the $(f x), the binding for "x"+-- By the time we are processing the $(f x), the binding for "x" -- will be in the global env, not the local one. topIdLvl id | isLocalId id = outerLevel             | otherwise    = impLevel@@ -830,7 +830,7 @@ -- E.g. given the name "Expr" return the type "Expr" tcMetaTy tc_name = do     t <- tcLookupTyCon tc_name-    return (mkTyConApp t [])+    return (mkTyConTy t)  isBrackStage :: ThStage -> Bool isBrackStage (Brack {}) = True@@ -877,7 +877,7 @@ {- Note [Extended defaults] ~~~~~~~~~~~~~~~~~~~~~-In interative mode (or with -XExtendedDefaultRules) we add () as the first type we+In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we try when defaulting.  This has very little real impact, except in the following case. Consider:         Text.Printf.printf "hello"
compiler/typecheck/TcErrors.hs view
@@ -2,6 +2,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcErrors(        reportUnsolved, reportAllUnsolved, warnAllUnsolved,        warnDefaulting,@@ -22,7 +25,7 @@ import TcEnv( tcInitTidyEnv ) import TcType import TcOrigin-import RnUnbound ( unknownNameSuggestions )+import GHC.Rename.Unbound ( unknownNameSuggestions ) import Type import TyCoRep import TyCoPpr          ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )@@ -227,7 +230,7 @@                             , cec_suppress = insolubleWC wanted                                  -- See Note [Suppressing error messages]                                  -- Suppress low-priority errors if there-                                 -- are insolule errors anywhere;+                                 -- are insoluble errors anywhere;                                  -- See #15539 and c.f. setting ic_status                                  -- in TcSimplify.setImplicationStatus                             , cec_warn_redundant = warn_redundant@@ -553,7 +556,7 @@     env = cec_tidy ctxt     tidy_cts = bagToList (mapBag (tidyCt env) simples) -    -- report1: ones that should *not* be suppresed by+    -- report1: ones that should *not* be suppressed by     --          an insoluble somewhere else in the tree     -- It's crucial that anything that is considered insoluble     -- (see TcRnTypes.insolubleCt) is caught here, otherwise
compiler/typecheck/TcExpr.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,                 tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,                 tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,@@ -36,8 +38,8 @@ import TcSimplify       ( simplifyInfer, InferMode(..) ) import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst ) import FamInstEnv       ( FamInstEnvs )-import RnEnv            ( addUsedGRE )-import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )+import GHC.Rename.Env   ( addUsedGRE )+import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) import TcEnv import TcArrows import TcMatches@@ -968,10 +970,10 @@ ************************************************************************ -} --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.+-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'. -- Here we get rid of it and add the finalizers to the global environment. ----- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))        res_ty   = do addModFinalizersWithLclEnv mod_finalizers@@ -1339,7 +1341,7 @@ The right error is the CHoleCan, which reports 'wurble' as out of scope, and tries to give its type. -Fortunately in tcArgs we still have acces to the function, so+Fortunately in tcArgs we still have access to the function, so we can check if it is a HsUnboundVar.  If so, we simply fail immediately.  We've already inferred the type of the function, so we'll /already/ have emitted a CHoleCan constraint; failing@@ -1957,6 +1959,9 @@ -}  checkThLocalId :: Id -> TcM ()+-- The renamer has already done checkWellStaged,+--   in RnSplice.checkThLocalName, so don't repeat that here.+-- Here we just just add constraints fro cross-stage lifting checkThLocalId id   = do  { mb_local_use <- getStageAndBindLevel (idName id)         ; case mb_local_use of@@ -1973,15 +1978,14 @@ -- we must check whether there's a cross-stage lift to do -- Examples   \x -> [|| x ||] --            [|| map ||]--- There is no error-checking to do, because the renamer did that ----- This is similar to checkCrossStageLifting in RnSplice, but+-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but -- this code is applied to *typed* brackets. -checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))+checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))   | isTopLevel top_lvl   = when (isExternalName id_name) (keepAlive id_name)-    -- See Note [Keeping things alive for Template Haskell] in RnSplice+    -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice    | otherwise   =     -- Nested identifiers, such as 'x' in@@ -2015,7 +2019,8 @@                    -- Update the pending splices         ; ps <- readMutVar ps_var         ; let pending_splice = PendingTcSplice id_name-                                 (nlHsApp (noLoc lift) (nlHsVar id))+                                 (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift))+                                          (nlHsVar id))         ; writeMutVar ps_var (pending_splice : ps)          ; return () }
compiler/typecheck/TcFlatten.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcFlatten(    FlattenMode(..),    flatten, flattenKind, flattenArgsNom,
compiler/typecheck/TcGenDeriv.hs view
@@ -16,6 +16,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcGenDeriv (         BagDerivStuff, DerivStuff(..), @@ -515,7 +517,7 @@    b_expr = nlHsVar b  unliftedCompare :: RdrName -> RdrName-                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to cmpare+                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to compare                 -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs                                                     -- Three results                 -> LHsExpr GhcPs
compiler/typecheck/TcGenFunctor.hs view
@@ -511,7 +511,7 @@         vars_needed = takeList insides as_RDRs         pat = nlConVarPat con_name vars_needed         -- Make sure to zip BEFORE invoking catMaybes. We want the variable-        -- indicies in each expression to match up with the argument indices+        -- indices in each expression to match up with the argument indices         -- in con_expr (defined below).         exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)                                    insides vars_needed
compiler/typecheck/TcGenGenerics.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcGenGenerics (canDoGenerics, canDoGenerics1,                       GenericKind(..),                       gen_Generic_binds, get_gen1_constrained_tys) where@@ -27,7 +29,7 @@ import FamInst import Module           ( moduleName, moduleNameFS                         , moduleUnitId, unitIdFS, getModule )-import IfaceEnv         ( newGlobalBinder )+import GHC.Iface.Env    ( newGlobalBinder ) import Name      hiding ( varName ) import RdrName import BasicTypes
compiler/typecheck/TcHoleErrors.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits                     , tcCheckHoleFit, tcSubsumes                     , withoutUnification@@ -54,7 +55,7 @@ import qualified Data.Map as Map import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) ) import HscTypes        ( ModIface_(..) )-import LoadIface       ( loadInterfaceForNameMaybe )+import GHC.Iface.Load  ( loadInterfaceForNameMaybe )  import PrelInfo (knownKeyNames)
compiler/typecheck/TcHsSyn.hs view
@@ -14,6 +14,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcHsSyn (         -- * Extracting types from HsSyn         hsLitType, hsPatType, hsLPatType,@@ -226,7 +228,7 @@   binding site.    Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.-  In a mutually recusive group+  In a mutually recursive group      rec { f = ...g...; g = ...f... }   we want the occurrence of g to point to the one zonked Id for g,   and the same for f.@@ -258,9 +260,9 @@ * DefaultFlexi: this is the common case, in situations like      length @alpha ([] @alpha)   It really doesn't matter what type we choose for alpha.  But-  we must choose a type!  We can't leae mutable unification+  we must choose a type!  We can't leave mutable unification   variables floating around: after typecheck is complete, every-  type variable occurrence must have a bindign site.+  type variable occurrence must have a binding site.    So we default it to 'Any' of the right kind. @@ -277,7 +279,7 @@ -}  data ZonkFlexi   -- See Note [Un-unified unification variables]-  = DefaultFlexi    -- Default unbound unificaiton variables to Any+  = DefaultFlexi    -- Default unbound unification variables to Any   | SkolemiseFlexi  -- Skolemise unbound unification variables                     -- See Note [Zonking the LHS of a RULE]   | RuntimeUnkFlexi -- Used in the GHCi debugger@@ -798,13 +800,19 @@ zonkExpr _ e@(HsRnBracketOut _ _ _)   = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) -zonkExpr env (HsTcBracketOut x body bs)-  = do bs' <- mapM zonk_b bs-       return (HsTcBracketOut x body bs')+zonkExpr env (HsTcBracketOut x wrap body bs)+  = do wrap' <- traverse zonkQuoteWrap wrap+       bs' <- mapM (zonk_b env) bs+       return (HsTcBracketOut x wrap' body bs')   where-    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e-                                      return (PendingTcSplice n e')+    zonkQuoteWrap (QuoteWrapper ev ty) = do+        let ev' = zonkIdOcc env ev+        ty' <- zonkTcTypeToTypeX env ty+        return (QuoteWrapper ev' ty') +    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e+                                           return (PendingTcSplice n e')+ zonkExpr env (HsSpliceE _ (HsSplicedT s)) =   runTopSplice s >>= zonkExpr env @@ -1754,7 +1762,7 @@     But the code implements something a bit better      * ZonkEnv contains ze_meta_tv_env, which maps-          from a MetaTyVar (unificaion variable)+          from a MetaTyVar (unification variable)           to a Type (not a TcType)      * In zonkTyVarOcc, we check this map to see if we have zonked
compiler/typecheck/TcHsType.hs view
@@ -11,6 +11,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcHsType (         -- Type signatures         kcClassSigType, tcClassSigType,@@ -79,7 +81,7 @@ import TcMType import TcValidity import TcUnify-import TcIface+import GHC.IfaceToCore import TcSimplify import TcHsSyn import TyCoRep@@ -265,7 +267,7 @@ -- Kind-checks/desugars an 'LHsSigType', --   solve equalities, --   and then kind-generalizes.--- This will never emit constraints, as it uses solveEqualities interally.+-- This will never emit constraints, as it uses solveEqualities internally. -- No validity checking or zonking -- Returns also a Bool indicating whether the type induced an insoluble constraint; -- True <=> constraint is insoluble@@ -634,7 +636,7 @@        ; ty' <- tc_lhs_type mode ty sig'        ; return (ty', sig') } --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate+-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate -- the splice location to the typechecker. Here we skip over it in order to have -- the same kind inferred for a given expression whether it was produced from -- splices or not.@@ -686,7 +688,7 @@       -- signatures) should have been removed by now     = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) --- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.+-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment -- while capturing the local environment. --@@ -1170,7 +1172,7 @@       (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $                                            ty_app_err ki_arg substed_fun_ki -      ---------------- HsValArg: a nomal argument (fun ty)+      ---------------- HsValArg: a normal argument (fun ty)       (HsValArg arg : args, Just (ki_binder, inner_ki))         -- next binder is invisible; need to instantiate it         | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;@@ -1770,7 +1772,7 @@   Every metavariable in a type must either be     (A) generalized, or     (B) promoted, or        See Note [Promotion in signatures]-    (C) zapped to Any       See Note [Naughty quantification candidates] in TcMType+    (C) a cause to error    See Note [Naughty quantification candidates] in TcMType  The kindGeneralize functions do not require pre-zonking; they zonk as they go.@@ -1787,7 +1789,7 @@ If an unsolved metavariable in a signature is not generalized (because we're not generalizing the construct -- e.g., pattern sig -- or because the metavars are constrained -- see kindGeneralizeSome)-we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]+we need to promote to maintain (WantedTvInv) of Note [TcLevel and untouchable type variables] in TcType. Note that promotion is identical in effect to generalizing and the reinstantiating with a fresh metavariable at the current level. So in some sense, we generalize *all* variables, but then re-instantiate@@ -1804,7 +1806,7 @@ the pattern signature (which is not kind-generalized). When we are checking the *body* of foo, though, we need to unify the type of x with the argument type of bar. At this point, the ambient TcLevel is 1, and spotting a-matavariable with level 2 would violate the (MetaTvInv) invariant of+matavariable with level 2 would violate the (WantedTvInv) invariant of Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing, we promote the metavariable to level 1. This is all done in kindGeneralizeNone. @@ -2446,7 +2448,7 @@ be a tough nut.  Previously, we laboriously (with help from the renamer)-tried to give T the polymoprhic kind+tried to give T the polymorphic kind    T :: forall ka -> ka -> kappa -> Type where kappa is a unification variable, even in the inferInitialKinds phase (which is what kcInferDeclHeader is all about).  But@@ -2507,7 +2509,7 @@   class C (a :: Type) where     type T (x :: f a) -As per Note [Ordering of implicit variables] in RnTypes, we want to quantify+As per Note [Ordering of implicit variables] in GHC.Rename.Types, we want to quantify the kind variables in left-to-right order of first occurrence in order to support visible kind application. But we cannot perform this analysis on just T alone, since its variable `a` actually occurs /before/ `f` if you consider@@ -2752,7 +2754,7 @@           -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv         -- Do a stable topological sort, following-       -- Note [Ordering of implicit variables] in RnTypes+       -- Note [Ordering of implicit variables] in GHC.Rename.Types        ; return (scopedSort spec_tkvs) }  -- | Generalize some of the free variables in the given type.@@ -3041,7 +3043,7 @@       text "unobscured by type families"  tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]--- Result is in 1-1 correpondence with orig_args+-- Result is in 1-1 correspondence with orig_args tcbVisibilities tc orig_args   = go (tyConKind tc) init_subst orig_args   where@@ -3101,7 +3103,7 @@ to be 'a', because when pretty printing we'll get             class C a b where                data D b a0-(NB: the tidying happens in the conversion to IfaceSyn, which happens+(NB: the tidying happens in the conversion to Iface syntax, which happens as part of pretty-printing a TyThing.)  That's why we look in the LocalRdrEnv to see what's in scope. This is@@ -3131,7 +3133,7 @@   | HsWC { hswc_ext  = sig_wcs, hswc_body = ib_ty } <- sig_ty   , HsIB { hsib_ext = implicit_hs_tvs          , hsib_body = hs_ty } <- ib_ty-  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty   = addSigCtxt ctxt hs_ty $     do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))             <- solveLocalEqualities "tcHsPartialSigType"    $@@ -3192,7 +3194,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [Recipe for checking a signature] -When we have a parital signature like+When we have a partial signature like    f,g :: forall a. a -> _ we do the following @@ -3204,7 +3206,7 @@   call tchsPartialSig (defined near this Note).  It kind-checks the   LHsSigWcType, creating fresh unification variables for each "_"   wildcard.  It's important that the wildcards for f and g are distinct-  becase they migh get instantiated completely differently.  E.g.+  because they might get instantiated completely differently.  E.g.      f,g :: forall a. a -> _      f x = a      g x = True@@ -3247,7 +3249,7 @@   TcBinds.chooseInferredQuantifiers. This is ill-kinded because   ordinary tuples can't contain constraints, but it works fine. And for   ordinary tuples we don't have the same limit as for constraint-  tuples (which need selectors and an assocated class).+  tuples (which need selectors and an associated class).  * Because it is ill-kinded, it trips an assert in writeMetaTyVar,   so now I disable the assertion if we are writing a type of
compiler/typecheck/TcInstDcls.hs view
@@ -10,6 +10,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where  #include "HsVersions.h"@@ -922,11 +925,11 @@   axiom AxDrep forall a b. D [(a,b]] = Drep a b There are several fiddly subtleties lurking here -* The representation tycon Drep is parameerised over the free+* The representation tycon Drep is parameterised over the free   variables of the pattern, in no particular order. So there is no   guarantee that 'p' and 'q' will come last in Drep's parameters, and   in the right order.  So, if the /patterns/ of the family insatance-  are eta-redcible, we re-order Drep's parameters to put the+  are eta-reducible, we re-order Drep's parameters to put the   eta-reduced type variables last.  * Although we eta-reduce the axiom, we eta-/expand/ the representation@@ -941,7 +944,7 @@    So in type-checking the LHS (DP Int) we need to check that it is   more polymorphic than the signature.  To do that we must skolemise-  the siganture and istantiate the call of DP.  So we end up with+  the signature and instantiate the call of DP.  So we end up with      data instance DP [b] @(k1,k2) (z :: (k1,k2)) where    Note that we must parameterise the representation tycon DPrep over@@ -978,7 +981,7 @@   tricky to sort out.  Consider       data family D k :: k   Then consider D (forall k2. k2 -> k2) Type Type-  The visibilty flags on an application of D may affected by the arguments+  The visibility flags on an application of D may affected by the arguments   themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities   does. @@ -1443,7 +1446,7 @@ NB3: the silent-superclass solution also generated tons of      extra dictionaries.  For example, in monad-transformer      code, when constructing a Monad dictionary you had to pass-     an Applicative dictionary; and to construct that you neede+     an Applicative dictionary; and to construct that you need      a Functor dictionary. Yet these extra dictionaries were      often never used.  Test T3064 compiled *far* faster after      silent superclasses were eliminated.
compiler/typecheck/TcInteract.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ module TcInteract (      solveSimpleGivens,   -- Solves [Ct]      solveSimpleWanteds,  -- Solves Cts@@ -74,7 +77,7 @@       - canonicalization       - inert reactions       - spontaneous reactions-      - top-level intreactions+      - top-level interactions    Each stage returns a StopOrContinue and may have sideffected    the inerts or worklist. @@ -685,7 +688,7 @@ interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)  interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })-  | insoluble  -- For insolubles, don't allow the constaint to be dropped+  | insoluble  -- For insolubles, don't allow the constraint to be dropped                -- which can happen with solveOneFromTheOther, so that                -- we get distinct error messages with -fdefer-type-errors                -- See Note [Do not add duplicate derived insolubles]@@ -996,7 +999,7 @@  * The CtEvidence is the goal to be solved -* The MaybeT anages early failure if we find a subgoal that+* The MaybeT manages early failure if we find a subgoal that   cannot be solved from instances.  * The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional@@ -1448,7 +1451,7 @@    [W] F Int b ~ Bool from which we can derive b.  This requires looking at the defining equations of a type family, ie. finding equation with a matching RHS (Bool in this example)-and infering values of type variables (b in this example) from the LHS patterns+and inferring values of type variables (b in this example) from the LHS patterns of the matching equation.  For closed type families we have to perform additional apartness check for the selected equation to check that the selected is guaranteed to fire for given LHS arguments.@@ -1506,7 +1509,7 @@     new_work :: xi_w ~ xi_i     cw := ci ; sym new_work Why?  Consider the simplest case when xi1 is a type variable.  If-we generate xi1~xi2, porcessing that constraint will kick out 'ci'.+we generate xi1~xi2, processing that constraint will kick out 'ci'. If we generate xi2~xi1, there is less chance of that happening. Of course it can and should still happen if xi1=a, xi1=Int, say. But we want to avoid it happening needlessly.@@ -1833,28 +1836,36 @@   = continueWith work_item    | EqPred eq_rel t1 t2 <- classifyPredType pred-  = -- See Note [Looking up primitive equalities in quantified constraints]-    case boxEqPred eq_rel t1 t2 of-      Nothing -> continueWith work_item-      Just (cls, tys)-        -> do { res <- matchLocalInst (mkClassPred cls tys) loc-              ; case res of-                  OneInst { cir_mk_ev = mk_ev }-                    -> chooseInstance work_item-                           (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })-                    where-                  _ -> continueWith work_item }+  = doTopReactEqPred work_item eq_rel t1 t2    | otherwise   = do { res <- matchLocalInst pred loc        ; case res of            OneInst {} -> chooseInstance work_item res            _          -> continueWith work_item }+   where-    ev = ctEvidence work_item+    ev   = ctEvidence work_item     loc  = ctEvLoc ev     pred = ctEvPred ev +doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)+doTopReactEqPred work_item eq_rel t1 t2+  -- See Note [Looking up primitive equalities in quantified constraints]+  | Just (cls, tys) <- boxEqPred eq_rel t1 t2+  = do { res <- matchLocalInst (mkClassPred cls tys) loc+       ; case res of+           OneInst { cir_mk_ev = mk_ev }+             -> chooseInstance work_item+                    (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })+           _ -> continueWith work_item }++  | otherwise+  = continueWith work_item+  where+    ev   = ctEvidence work_item+    loc = ctEvLoc ev+     mk_eq_ev cls tys mk_ev evs       = case (mk_ev evs) of           EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)@@ -2202,7 +2213,7 @@ Note [Improvement orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A very delicate point is the orientation of derived equalities-arising from injectivity improvement (#12522).  Suppse we have+arising from injectivity improvement (#12522).  Suppose we have   type family F x = t | t -> x   type instance F (a, Int) = (Int, G a) where G is injective; and wanted constraints@@ -2495,7 +2506,7 @@        g :: forall a. Q [a] => [a] -> Int        g x = wob x -From 'g' we get the impliation constraint:+From 'g' we get the implication constraint:             forall a. Q [a] => (Q [beta], R beta [a]) If we react (Q [beta]) with its top-level axiom, we end up with a (P beta), which we have no way of discharging. On the other hand,
compiler/typecheck/TcMType.hs view
@@ -11,12 +11,15 @@  {-# LANGUAGE CPP, TupleSections, MultiWayIf #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcMType (   TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,    --------------------------------   -- Creating new mutable type variables   newFlexiTyVar,+  newNamedFlexiTyVar,   newFlexiTyVarTy,              -- Kind -> TcM TcType   newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]   newOpenFlexiTyVarTy, newOpenTypeKind,@@ -730,15 +733,22 @@ unification variable.  So that's what we do. -} +metaInfoToTyVarName :: MetaInfo -> FastString+metaInfoToTyVarName  meta_info =+  case meta_info of+       TauTv       -> fsLit "t"+       FlatMetaTv  -> fsLit "fmv"+       FlatSkolTv  -> fsLit "fsk"+       TyVarTv     -> fsLit "a"+ newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar+newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi++newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar -- Make a new meta tyvar out of thin air-newAnonMetaTyVar meta_info kind-  = do  { let s = case meta_info of-                        TauTv       -> fsLit "t"-                        FlatMetaTv  -> fsLit "fmv"-                        FlatSkolTv  -> fsLit "fsk"-                        TyVarTv      -> fsLit "a"-        ; name    <- newMetaTyVarName s+newNamedAnonMetaTyVar tyvar_name meta_info kind++  = do  { name    <- newMetaTyVarName tyvar_name         ; details <- newMetaDetails meta_info         ; let tyvar = mkTcTyVar name kind details         ; traceTc "newAnonMetaTyVar" (ppr tyvar)@@ -963,6 +973,10 @@ newFlexiTyVar :: Kind -> TcM TcTyVar newFlexiTyVar kind = newAnonMetaTyVar TauTv kind +-- | Create a new flexi ty var with a specific name+newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar+newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind+ newFlexiTyVarTy :: Kind -> TcM TcType newFlexiTyVarTy kind = do     tc_tyvar <- newFlexiTyVar kind@@ -1077,7 +1091,7 @@ We gather these variables using a CandidatesQTvs record:   DV { dv_kvs: Variables free in the kind of a free type variable                or of a forall-bound type variable-     , dv_tvs: Variables sytactically free in the type }+     , dv_tvs: Variables syntactically free in the type }  So:  dv_kvs            are the kind variables of the type      (dv_tvs - dv_kvs) are the type variable of the type@@ -1137,8 +1151,7 @@  What then should we do with alpha?  During generalization, every metavariable is either (A) promoted, (B) generalized, or (C) zapped-(according again to Note [Recipe for checking a signature] in-TcHsType).+(according to Note [Recipe for checking a signature] in TcHsType).   * We can't generalise it.  * We can't promote it, because its kind prevents that@@ -1146,11 +1159,14 @@    go into the typing environment (as the type of some let-bound    variable, say), and then chaos erupts when we try to instantiate. -So, we zap it, eagerly, to Any. We don't have to do this eager zapping-in terms (say, in `length []`) because terms are never re-examined before-the final zonk (which zaps any lingering metavariables to Any).+Previously, we zapped it to Any. This worked, but it had the unfortunate+effect of causing Any sometimes to appear in error messages. If this+kind of signature happens, the user probably has made a mistake -- no+one really wants Any in their types. So we now error. This must be+a hard error (failure in the monad) to avoid other messages from mentioning+Any. -We do this eager zapping in candidateQTyVars, which always precedes+We do this eager erroring in candidateQTyVars, which always precedes generalisation, because at that moment we have a clear picture of what skolems are in scope within the type itself (e.g. that 'forall arg'). @@ -1235,13 +1251,14 @@ -- See Note [Dependent type variables] candidateQTyVarsOfType :: TcType       -- not necessarily zonked                        -> TcM CandidatesQTvs-candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty+candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty  -- | Like 'candidateQTyVarsOfType', but over a list of types -- The variables to quantify must have a TcLevel strictly greater than -- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs-candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys+candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty)+                                     mempty tys  -- | Like 'candidateQTyVarsOfType', but consider every free variable -- to be dependent. This is appropriate when generalizing a *kind*,@@ -1249,11 +1266,12 @@ -- to Type.) candidateQTyVarsOfKind :: TcKind       -- Not necessarily zonked                        -> TcM CandidatesQTvs-candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty+candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty  candidateQTyVarsOfKinds :: [TcKind]    -- Not necessarily zonked                        -> TcM CandidatesQTvs-candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys+candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty)+                                    mempty tys  delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars@@ -1262,7 +1280,8 @@        , dv_cvs = cvs `delVarSetList`  vars }  collect_cand_qtvs-  :: Bool            -- True <=> consider every fv in Type to be dependent+  :: TcType          -- original type that we started recurring into; for errors+  -> Bool            -- True <=> consider every fv in Type to be dependent   -> VarSet          -- Bound variables (locals only)   -> CandidatesQTvs  -- Accumulating parameter   -> Type            -- Not necessarily zonked@@ -1272,14 +1291,14 @@ --   * Looks through meta-tyvars as it goes; --     no need to zonk in advance -----   * Needs to be monadic anyway, because it does the zap-naughty---     stuff; see Note [Naughty quantification candidates]+--   * Needs to be monadic anyway, because it handles naughty+--     quantification; see Note [Naughty quantification candidates] -- --   * Returns fully-zonked CandidateQTvs, including their kinds --     so that subsequent dependency analysis (to build a well --     scoped telescope) works correctly -collect_cand_qtvs is_dep bound dvs ty+collect_cand_qtvs orig_ty is_dep bound dvs ty   = go dvs ty   where     is_bound tv = tv `elemVarSet` bound@@ -1292,8 +1311,8 @@     go dv (FunTy _ arg res) = foldlM go dv [arg, res]     go dv (LitTy {})        = return dv     go dv (CastTy ty co)    = do dv1 <- go dv ty-                                 collect_cand_qtvs_co bound dv1 co-    go dv (CoercionTy co)   = collect_cand_qtvs_co bound dv co+                                 collect_cand_qtvs_co orig_ty bound dv1 co+    go dv (CoercionTy co)   = collect_cand_qtvs_co orig_ty bound dv co      go dv (TyVarTy tv)       | is_bound tv      = return dv@@ -1303,17 +1322,17 @@                                   Nothing     -> go_tv dv tv }      go dv (ForAllTy (Bndr tv _) ty)-      = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)-           ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty }+      = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv)+           ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty }      -----------------     go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv       | tv `elemDVarSet` kvs-      = return dv  -- We have met this tyvar aleady+      = return dv  -- We have met this tyvar already        | not is_dep       , tv `elemDVarSet` tvs-      = return dv  -- We have met this tyvar aleady+      = return dv  -- We have met this tyvar already        | otherwise       = do { tv_kind <- zonkTcType (tyVarKind tv)@@ -1322,25 +1341,23 @@                  -- (#15795) and to make the naughty check                  -- (which comes next) works correctly +           ; let tv_kind_vars = tyCoVarsOfType tv_kind            ; cur_lvl <- getTcLevel            ; if |  tcTyVarLevel tv <= cur_lvl                 -> return dv   -- this variable is from an outer context; skip                                -- See Note [Use level numbers ofor quantification] -                |  intersectsVarSet bound (tyCoVarsOfType tv_kind)+                |  intersectsVarSet bound tv_kind_vars                    -- the tyvar must not be from an outer context, but we have                    -- already checked for this.                    -- See Note [Naughty quantification candidates]-                -> do { traceTc "Zapping naughty quantifier" $+                -> do { traceTc "Naughty quantifier" $                           vcat [ ppr tv <+> dcolon <+> ppr tv_kind                                , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound)-                               , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet $-                                                            tyCoVarsOfType tv_kind) ]--                      ; writeMetaTyVar tv (anyTypeOfKind tv_kind)+                               , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] -                      -- See Note [Recurring into kinds for candidateQTyVars]-                      ; collect_cand_qtvs True bound dv tv_kind }+                      ; let escapees = intersectVarSet bound tv_kind_vars+                      ; naughtyQuantification orig_ty tv escapees }                  |  otherwise                 -> do { let tv' = tv `setTyVarKind` tv_kind@@ -1349,15 +1366,16 @@                                 -- See Note [Order of accumulation]                          -- See Note [Recurring into kinds for candidateQTyVars]-                      ; collect_cand_qtvs True bound dv' tv_kind } }+                      ; collect_cand_qtvs orig_ty True bound dv' tv_kind } } -collect_cand_qtvs_co :: VarSet -- bound variables+collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors+                     -> VarSet -- bound variables                      -> CandidatesQTvs -> Coercion                      -> TcM CandidatesQTvs-collect_cand_qtvs_co bound = go_co+collect_cand_qtvs_co orig_ty bound = go_co   where-    go_co dv (Refl ty)             = collect_cand_qtvs True bound dv ty-    go_co dv (GRefl _ ty mco)      = do dv1 <- collect_cand_qtvs True bound dv ty+    go_co dv (Refl ty)             = collect_cand_qtvs orig_ty True bound dv ty+    go_co dv (GRefl _ ty mco)      = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty                                         go_mco dv1 mco     go_co dv (TyConAppCo _ _ cos)  = foldlM go_co dv cos     go_co dv (AppCo co1 co2)       = foldlM go_co dv [co1, co2]@@ -1365,8 +1383,8 @@     go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos     go_co dv (AxiomRuleCo _ cos)   = foldlM go_co dv cos     go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov-                                        dv2 <- collect_cand_qtvs True bound dv1 t1-                                        collect_cand_qtvs True bound dv2 t2+                                        dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1+                                        collect_cand_qtvs orig_ty True bound dv2 t2     go_co dv (SymCo co)            = go_co dv co     go_co dv (TransCo co1 co2)     = foldlM go_co dv [co1, co2]     go_co dv (NthCo _ _ co)        = go_co dv co@@ -1385,7 +1403,7 @@      go_co dv (ForAllCo tcv kind_co co)       = do { dv1 <- go_co dv kind_co-           ; collect_cand_qtvs_co (bound `extendVarSet` tcv) dv1 co }+           ; collect_cand_qtvs_co orig_ty (bound `extendVarSet` tcv) dv1 co }      go_mco dv MRefl    = return dv     go_mco dv (MCo co) = go_co dv co@@ -1401,7 +1419,7 @@       | cv `elemVarSet` cvs = return dv          -- See Note [Recurring into kinds for candidateQTyVars]-      | otherwise           = collect_cand_qtvs True bound+      | otherwise           = collect_cand_qtvs orig_ty True bound                                     (dv { dv_cvs = cvs `extendVarSet` cv })                                     (idType cv) @@ -1569,7 +1587,7 @@        ; let dep_kvs     = scopedSort $ dVarSetElems dep_tkvs                        -- scopedSort: put the kind variables into                        --    well-scoped order.-                       --    E.g.  [k, (a::k)] not the other way roud+                       --    E.g.  [k, (a::k)] not the other way round               nondep_tvs  = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)                  -- See Note [Dependent type variables]@@ -1721,7 +1739,7 @@            -- promote, skolemise, or zap-to-Any, to satisfy TcHsType            --    Note [Recipe for checking a signature]            -- Otherwise we get level-number assertion failures. It doesn't matter much-           -- because we are in an error siutation anyway.+           -- because we are in an error situation anyway.            ; return False         }       where@@ -2305,8 +2323,8 @@ %************************************************************************ %*                                                                      *              Levity polymorphism checks-*                                                                      *-************************************************************************+*                                                                       *+*************************************************************************  See Note [Levity polymorphism checking] in DsMonad @@ -2351,3 +2369,48 @@   where     (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty     tidy_ki             = tidyType tidy_env (tcTypeKind ty)++{-+%************************************************************************+%*                                                                      *+             Error messages+*                                                                       *+*************************************************************************++-}++-- See Note [Naughty quantification candidates]+naughtyQuantification :: TcType   -- original type user wanted to quantify+                      -> TcTyVar  -- naughty var+                      -> TyVarSet -- skolems that would escape+                      -> TcM a+naughtyQuantification orig_ty tv escapees+  = do { orig_ty1 <- zonkTcType orig_ty  -- in case it's not zonked++       ; escapees' <- mapM zonkTcTyVarToTyVar $+                      nonDetEltsUniqSet escapees+                     -- we'll just be printing, so no harmful non-determinism++       ; let fvs  = tyCoVarsOfTypeWellScoped orig_ty1+             env0 = tidyFreeTyCoVars emptyTidyEnv fvs+             env  = env0 `delTidyEnvList` escapees'+                    -- this avoids gratuitous renaming of the escaped+                    -- variables; very confusing to users!++             orig_ty'   = tidyType env orig_ty1+             ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env)+             doc = pprWithExplicitKindsWhen True $+                   vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees'+                              , quotes $ ppr_tidied escapees'+                              , text "would escape" <+> itsOrTheir escapees' <+> text "scope"+                              ]+                        , sep [ text "if I tried to quantify"+                              , ppr_tidied [tv]+                              , text "in this type:"+                              ]+                        , nest 2 (pprTidiedType orig_ty')+                        , text "(Indeed, I sometimes struggle even printing this correctly,"+                        , text " due to its ill-scoped nature.)"+                        ]++       ; failWithTcM (env, doc) }
compiler/typecheck/TcMatches.hs view
@@ -14,6 +14,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,                    TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,                    tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,@@ -375,7 +377,7 @@  -- Don't set the error context for an ApplicativeStmt.  It ought to be -- possible to do this with a popErrCtxt in the tcStmt case for--- ApplicativeStmt, but it did someting strange and broke a test (ado002).+-- ApplicativeStmt, but it did something strange and broke a test (ado002). tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside   | ApplicativeStmt{} <- stmt   = do  { (stmt', (stmts', thing)) <-@@ -691,7 +693,7 @@        ; using' <- tcPolyExpr using using_poly_ty        ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' -       --------------- Bulding the bindersMap ----------------+       --------------- Building the bindersMap ----------------        ; let mk_n_bndr :: Name -> TcId -> TcId              mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
compiler/typecheck/TcPat.hs view
@@ -11,6 +11,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)              , tcPat, tcPat_O, tcPats              , addDataConStupidTheta, badFieldCon, polyPatSig ) where@@ -608,10 +610,10 @@                                ge' minus''         ; return (pat', res) } --- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.+-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. -- Here we get rid of it and add the finalizers to the global environment. ----- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))             pat_ty thing_inside   = do addModFinalizersWithLclEnv mod_finalizers
compiler/typecheck/TcPatSyn.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind                 , tcPatSynBuilderOcc, nonBidirectionalErr   ) where@@ -171,7 +173,7 @@                  = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)              req_theta = map evVarPred req_dicts -       -- Report coercions that esacpe+       -- Report coercions that escape        -- See Note [Coercions that escape]        ; args <- mapM zonkId args        ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts@@ -237,7 +239,7 @@ ~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   data AST a = Sym [a]-  class Prj s where { prj :: [a] -> Maybe (s a)+  class Prj s where { prj :: [a] -> Maybe (s a) }   pattern P x <= Sym (prj -> Just x)  Here we get a matcher with this type@@ -261,7 +263,7 @@    forall ex_tvs. arg_ty  After that, Note [Naughty quantification candidates] in TcMType takes-over, and zonks any such naughty variables to Any.+over and errors.  Note [Remove redundant provided dicts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -283,7 +285,7 @@   pattern Bam x y <- (MkS (x::a), MkS (y::a)))  The pattern (Bam x y) binds two (Ord a) dictionaries, but we only-need one.  Agian mkMimimalWithSCs removes the redundant one.+need one.  Again mkMimimalWithSCs removes the redundant one.  Note [Equality evidence in pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -312,7 +314,7 @@ Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ #14507 showed an example where the inferred type of the matcher-for the pattern synonym was somethign like+for the pattern synonym was something like    $mSO :: forall (r :: TYPE rep) kk (a :: k).            TypeRep k a            -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)@@ -853,7 +855,9 @@        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds        ; return builder_binds } } } +#if __GLASGOW_HASKELL__ <= 810   | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with+#endif   where     mb_match_group        = case dir of@@ -1037,7 +1041,7 @@  Note [Redundant constraints for builder] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The builder can have redundant constraints, which are awkard to eliminate.+The builder can have redundant constraints, which are awkward to eliminate. Consider    pattern P = Just 34 To match against this pattern we need (Eq a, Num a).  But to build@@ -1074,7 +1078,7 @@ specified type.  We check the pattern *as a pattern*, so the type signature is a pattern signature, and so brings 'a' and 'b' into scope.  But we don't have a way to bind 'a, b' in the LHS, as we do-'x', say.  Nevertheless, the sigature may be useful to constrain+'x', say.  Nevertheless, the signature may be useful to constrain the type.  When making the binding for the *builder*, though, we don't want
compiler/typecheck/TcPluginM.hs view
@@ -57,7 +57,7 @@ import qualified TcEnv     as TcM import qualified TcMType   as TcM import qualified FamInst   as TcM-import qualified IfaceEnv+import qualified GHC.Iface.Env as IfaceEnv import qualified Finder  import FamInstEnv ( FamInstEnv )
compiler/typecheck/TcRnDriver.hs view
@@ -17,6 +17,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcRnDriver (         tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,         tcRnImportDecls,@@ -49,24 +51,24 @@ import GhcPrelude  import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )-import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )-import IfaceEnv( externaliseName )+import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )+import GHC.Iface.Env     ( externaliseName ) import TcHsType import TcValidity( checkValidType ) import TcMatches import Inst( deeplyInstantiate ) import TcUnify( checkConstraints )-import RnTypes-import RnExpr-import RnUtils ( HsDocContext(..) )-import RnFixity ( lookupFixityRn )+import GHC.Rename.Types+import GHC.Rename.Expr+import GHC.Rename.Utils  ( HsDocContext(..) )+import GHC.Rename.Fixity ( lookupFixityRn ) import MkId import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags import GHC.Hs-import IfaceSyn ( ShowSub(..), showToHeader )-import IfaceType( ShowForAllFlag(..) )+import GHC.Iface.Syntax ( ShowSub(..), showToHeader )+import GHC.Iface.Type   ( ShowForAllFlag(..) ) import PatSyn( pprPatSynType ) import PrelNames import PrelInfo@@ -87,24 +89,24 @@                  , famInstEnvElts, extendFamInstEnvList, normaliseType ) import TcAnnotations import TcBinds-import MkIface          ( coAxiomToIfaceDecl )+import GHC.Iface.Utils  ( coAxiomToIfaceDecl ) import HeaderInfo       ( mkPrelImports ) import TcDefaults import TcEnv import TcRules import TcForeign import TcInstDcls-import TcIface+import GHC.IfaceToCore import TcMType import TcType import TcSimplify import TcTyClsDecls import TcTypeable ( mkTypeableBinds ) import TcBackpack-import LoadIface-import RnNames-import RnEnv-import RnSource+import GHC.Iface.Load+import GHC.Rename.Names+import GHC.Rename.Env+import GHC.Rename.Source import ErrUtils import Id import IdInfo( IdDetails(..) )@@ -633,7 +635,7 @@               <- rnTopSrcDecls first_group          -- The empty list is for extra dependencies coming from .hs-boot files-        -- See Note [Extra dependencies from .hs-boot files] in RnSource+        -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Source          ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {               -- NB: setGblEnv **before** captureTopConstraints so that@@ -735,7 +737,9 @@              -- TODO: Maybe setGlobalTypeEnv should be strict.           setGlobalTypeEnv tcg_env_w_binds type_env' } +#if __GLASGOW_HASKELL__ <= 810   | otherwise = panic "checkHiBootIface: unreachable code"+#endif  {- Note [DFun impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -767,7 +771,7 @@  This most works well, but there is one problem: DFuns!  We do not want to look at the mb_insts of the ModDetails in SelfBootInfo, because a-dfun in one of those ClsInsts is gotten (in TcIface.tcIfaceInst) by a+dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a (lazily evaluated) lookup in the if_rec_types.  We could extend the type env, do a setGloblaTypeEnv etc; but that all seems very indirect. It is much more directly simply to extract the DFunIds from the@@ -1197,7 +1201,7 @@     -- It would have been best if this was purely a question of defaults     -- (i.e., a user could explicitly ask for one behavior or another) but     -- the current role system isn't expressive enough to do this.-    -- Having explict proj-roles would solve this problem.+    -- Having explicit proj-roles would solve this problem.      rolesSubtypeOf [] [] = True     -- NB: this relation is the OPPOSITE of the subroling relation@@ -1834,7 +1838,7 @@ ":Main".)  This is unusual: it's a LocalId whose Name has a Module from another-module.  Tiresomely, we must filter it out again in MkIface, les we+module. Tiresomely, we must filter it out again in GHC.Iface.Utils, less we get two defns for 'main' in the interface file!  @@ -2165,7 +2169,7 @@ #14963 reveals another bug that when deferred type errors is enabled in GHCi, any reference of imported/loaded variables (directly or indirectly) in interactively issued naked expressions will cause ghc panic. See more-detailed dicussion in #14963.+detailed discussion in #14963.  The interactively issued declarations, statements, as well as the modules loaded into GHCi, are not affected. That means, for declaration, you could@@ -2782,7 +2786,7 @@                          _            -> False              -- Data cons (workers and wrappers), pattern synonyms,              -- etc are suppressed (unless -dppr-debug),-             -- because they appear elsehwere+             -- because they appear elsewhere      ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id))) @@ -2813,7 +2817,7 @@          roles = tyConRoles tc          boring_role | isClassTyCon tc = Nominal                      | otherwise       = Representational-            -- Matches the choice in IfaceSyn, calls to pprRoles+            -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles      ppr_ax ax = ppr (coAxiomToIfaceDecl ax)       -- We go via IfaceDecl rather than using pprCoAxiom
compiler/typecheck/TcRnExports.hs view
@@ -15,9 +15,9 @@ import TcRnMonad import TcEnv import TcType-import RnNames-import RnEnv-import RnUnbound ( reportUnboundName )+import GHC.Rename.Names+import GHC.Rename.Env+import GHC.Rename.Unbound ( reportUnboundName ) import ErrUtils import Id import IdInfo@@ -40,8 +40,8 @@  import Control.Monad import DynFlags-import RnHsDoc          ( rnHsDoc )-import RdrHsSyn        ( setRdrNameSpace )+import GHC.Rename.Doc   ( rnHsDoc )+import RdrHsSyn         ( setRdrNameSpace ) import Data.Either      ( partitionEithers )  {-
compiler/typecheck/TcRnMonad.hs view
@@ -8,11 +8,12 @@ {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# LANGUAGE ViewPatterns #-}   module TcRnMonad(-  -- * Initalisation+  -- * Initialisation   initTc, initTcWithGbl, initTcInteractive, initTcRnIf,    -- * Simple accessors@@ -1206,7 +1207,7 @@  -- | Apply the function to all elements on the input list -- If all succeed, return the list of results--- Othewise fail, propagating all errors+-- Otherwise fail, propagating all errors mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b] mapAndReportM f xs   = do { mb_rs <- mapM (attemptM . f) xs@@ -1255,7 +1256,7 @@         ; case mb_res of             Just res | not (errorsFound dflags msgs)                      , not (insolubleWC lie)-              -> -- 'main' succeeed with no errors+              -> -- 'main' succeeded with no errors                  do { addMessages msgs  -- msgs might still have warnings                     ; emitConstraints lie                     ; return res }@@ -1705,8 +1706,8 @@ might have been the actual original cause of the exception!  For example (#12529):    f = p @ Int-Here 'p' is out of scope, so we get an insolube Hole constraint. But-the visible type application fails in the monad (thows an exception).+Here 'p' is out of scope, so we get an insoluble Hole constraint. But+the visible type application fails in the monad (throws an exception). We must not discard the out-of-scope error.  So we /retain the insoluble constraints/ if there is an exception.
compiler/typecheck/TcRules.hs view
@@ -108,7 +108,7 @@        --      RULE:  forall v. fst (ss v) = fst v        -- The type of the rhs of the rule is just a, but v::(a,(b,c))        ---       -- We also need to get the completely-uconstrained tyvars of+       -- We also need to get the completely-unconstrained tyvars of        -- the LHS, lest they otherwise get defaulted to Any; but we do that        -- during zonking (see TcHsSyn.zonkRule)
compiler/typecheck/TcSMonad.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ -- Type definitions for the constraint solver module TcSMonad ( @@ -155,7 +157,7 @@ import Name import Module ( HasModule, getModule ) import RdrName ( GlobalRdrEnv, GlobalRdrElt )-import qualified RnEnv as TcM+import qualified GHC.Rename.Env as TcM import Var import VarEnv import VarSet@@ -515,7 +517,7 @@      constraint led to the ability to define unsafeCoerce      in #17267. -   - Exception 2: the magic built-in instace for (~) has no+   - Exception 2: the magic built-in instance for (~) has no      such guarantee.  It behaves as if we had          class    (a ~# b) => (a ~ b) where {}          instance (a ~# b) => (a ~ b) where {}@@ -707,7 +709,7 @@         , inert_funeqs :: FunEqMap Ct               -- All CFunEqCans; index is the whole family head type.-              -- All Nominal (that's an invarint of all CFunEqCans)+              -- All Nominal (that's an invariant of all CFunEqCans)               -- LHS is fully rewritten (modulo eqCanRewrite constraints)               --     wrt inert_eqs               -- Can include all flavours, [G], [W], [WD], [D]@@ -776,7 +778,7 @@  From the fourth invariant it follows that the list is    - A single [G], or-   - Zero or one [D] or [WD], followd by any number of [W]+   - Zero or one [D] or [WD], followed by any number of [W]  The Wanteds can't rewrite anything which is why we put them last @@ -791,7 +793,7 @@     the InertCans. They can be [G], [W], [WD], or [D].    * The inert_flat_cache.  This is used when flattening, to get maximal-    sharing. Everthing in the inert_flat_cache is [G] or [WD]+    sharing. Everything in the inert_flat_cache is [G] or [WD]      It contains lots of things that are still in the work-list.     E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the@@ -1854,7 +1856,7 @@ (#12468, #11325).  Hence:- * In the main simlifier loops in TcSimplify (solveWanteds,+ * In the main simplifier loops in TcSimplify (solveWanteds,    simpl_loop), we feed the insolubles in solveSimpleWanteds,    so that they get rewritten (albeit not solved). @@ -2114,7 +2116,7 @@   where     eqs_given_here :: EqualCtList -> Bool     eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]-                              -- Givens are always a sigleton+                              -- Givens are always a singleton       = not (skolem_bound_here tv) && ct_given_here ct     eqs_given_here _ = False @@ -3402,12 +3404,32 @@   = do { useVars (coVarsOfCo co)        ; wrapTcS $ TcM.fillCoercionHole hole co }   | otherwise-  = do { let co_var = coHoleCoVar hole+  = -- See Note [Yukky eq_sel for a HoleDest]+    do { let co_var = coHoleCoVar hole        ; setEvBind (mkWantedEvBind co_var tm)        ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) }  setWantedEvTerm (EvVarDest ev_id) tm   = setEvBind (mkWantedEvBind ev_id tm)++{- Note [Yukky eq_sel for a HoleDest]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How can it be that a Wanted with HoleDest gets evidence that isn't+just a coercion? i.e. evTermCoercion_maybe returns Nothing.++Consider [G] forall a. blah => a ~ T+         [W] S ~# T++Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~+T) in the quantified constraints, and wraps the (boxed) evidence it+gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put+that term into a coercion, so we add a value binding+    h = eq_sel (...)+and the coercion variable h to fill the coercion hole.+We even re-use the CoHole's Id for this binding!++Yuk!+-}  setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () setEvBindIfWanted ev tm
compiler/typecheck/TcSimplify.hs view
@@ -181,7 +181,7 @@ For example polykinds/T12593, T15577, and many others.  Take care to ensure that you emit the insoluble constraints before-failing, because they are what will ulimately lead to the error+failing, because they are what will ultimately lead to the error messsage! -} @@ -1064,7 +1064,7 @@ --   (a) Free in the environment --   (b) Mentioned in a constraint we can't generalise --   (c) Connected by an equality to (a) or (b)--- Also return CoVars that appear free in the final quatified types+-- Also return CoVars that appear free in the final quantified types --   we can't quantify over these, and we must make sure they are in scope decideMonoTyVars infer_mode name_taus psigs candidates   = do { (no_quant, maybe_quant) <- pick infer_mode candidates@@ -1907,7 +1907,7 @@    f x y = ... We'll have    [G] d1 :: (a~b)-and we'll specuatively generate the evidence binding+and we'll speculatively generate the evidence binding    [G] d2 :: (a ~# b) = sc_sel d  Now d2 is available for solving.  But it may not be needed!  Usually@@ -1917,7 +1917,7 @@  * It won't always be dropped (#13032).  In the case of an    unlifted-equality superclass like d2 above, we generate        case heq_sc d1 of d2 -> ...-   and we can't (in general) drop that case exrpession in case+   and we can't (in general) drop that case expression in case    d1 is bottom.  So it's technically unsound to have added it    in the first place. @@ -2057,7 +2057,7 @@     via solveNestedImplications, because we'll just get the     same [D] again -  * If we *do* re-solve, we'll get an ininite loop. It is cut off by+  * If we *do* re-solve, we'll get an infinite loop. It is cut off by     the fixed bound of 10, but solving the next takes 10*10*...*10 (ie     exponentially many) iterations! @@ -2160,7 +2160,7 @@  There is one caveat: -1.  When infering most-general types (in simplifyInfer), we do *not*+1.  When inferring most-general types (in simplifyInfer), we do *not*     float anything out if the implication binds equality constraints,     because that defeats the OutsideIn story.  Consider        data T a where@@ -2543,6 +2543,11 @@  The possible dependence on givens, and evidence bindings, is more subtle than we'd realised at first.  See #14584.++How can (4) arise? Suppose we have (k :: *), (a :: k), and ([G} k ~ *).+Then form an equality like (a ~ Int) we might end up with+    [W] co1 :: k ~ *+    [W] co2 :: (a |> co1) ~ Int   *********************************************************************************
compiler/typecheck/TcSplice.hs view
@@ -15,8 +15,11 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcSplice(      tcSpliceExpr, tcTypedBracket, tcUntypedBracket, --     runQuasiQuoteExpr, runQuasiQuotePat,@@ -58,22 +61,22 @@ import HscMain         -- These imports are the reason that TcSplice         -- is very high up the module hierarchy-import RnSplice( traceSplice, SpliceInfo(..))+import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) import RdrName import HscTypes import GHC.ThToHs-import RnExpr-import RnEnv-import RnUtils ( HsDocContext(..) )-import RnFixity ( lookupFixityRn_help )-import RnTypes+import GHC.Rename.Expr+import GHC.Rename.Env+import GHC.Rename.Utils  ( HsDocContext(..) )+import GHC.Rename.Fixity ( lookupFixityRn_help )+import GHC.Rename.Types import TcHsSyn import TcSimplify import Type import NameSet import TcMType import TcHsType-import TcIface+import GHC.IfaceToCore import TyCoRep import FamInst import FamInstEnv@@ -86,14 +89,14 @@ import Hooks import Var import Module-import LoadIface+import GHC.Iface.Load import Class import TyCon import CoAxiom import PatSyn import ConLike import DataCon-import TcEvidence( TcEvBinds(..) )+import TcEvidence import Id import IdInfo import DsExpr@@ -172,68 +175,132 @@                                        -- should get thrown into the constraint set                                        -- from outside the bracket +       -- Make a new type variable for the type of the overall quote+       ; m_var <- mkTyVarTy <$> mkMetaTyVar+       -- Make sure the type variable satisfies Quote+       ; ev_var <- emitQuoteWanted m_var+       -- Bundle them together so they can be used in DsMeta for desugaring+       -- brackets.+       ; let wrapper = QuoteWrapper ev_var m_var        -- Typecheck expr to make sure it is valid,        -- Throw away the typechecked expression but return its type.        -- We'll typecheck it again when we splice it in somewhere-       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $+       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $                                 tcInferRhoNC expr                                 -- NC for no context; tcBracket does that        ; let rep = getRuntimeRep expr_ty--       ; meta_ty <- tcTExpTy expr_ty+       ; meta_ty <- tcTExpTy m_var expr_ty        ; ps' <- readMutVar ps_ref        ; texpco <- tcLookupId unsafeTExpCoerceName        ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")                        rn_expr-                       (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])-                                      (noLoc (HsTcBracketOut noExtField brack ps'))))+                       (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)+                                                  (nlHsTyApp texpco [rep, expr_ty]))+                                      (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps'))))                        meta_ty res_ty } tcTypedBracket _ other_brack _   = pprPanic "tcTypedBracket" (ppr other_brack)  -- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)+-- See Note [Typechecking Overloaded Quotes] tcUntypedBracket rn_expr brack ps res_ty   = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)-       ; ps' <- mapM tcPendingSplice ps-       ; meta_ty <- tcBrackTy brack-       ; traceTc "tc_bracket done untyped" (ppr meta_ty)-       ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")-                       rn_expr (HsTcBracketOut noExtField brack ps') meta_ty res_ty } ++       -- Create the type m Exp for expression bracket, m Type for a type+       -- bracket and so on. The brack_info is a Maybe because the+       -- VarBracket ('a) isn't overloaded, but also shouldn't contain any+       -- splices.+       ; (brack_info, expected_type) <- brackTy brack++       -- Match the expected type with the type of all the internal+       -- splices. They might have further constrained types and if they do+       -- we want to reflect that in the overall type of the bracket.+       ; ps' <- case quoteWrapperTyVarTy <$> brack_info of+                  Just m_var -> mapM (tcPendingSplice m_var) ps+                  Nothing -> ASSERT(null ps) return []++       ; traceTc "tc_bracket done untyped" (ppr expected_type)++       -- Unify the overall type of the bracket with the expected result+       -- type+       ; tcWrapResultO BracketOrigin rn_expr+            (HsTcBracketOut noExtField brack_info brack ps')+            expected_type res_ty++       }++-- | A type variable with kind * -> * named "m"+mkMetaTyVar :: TcM TyVar+mkMetaTyVar =+  newNamedFlexiTyVar (fsLit "m") (mkVisFunTy liftedTypeKind liftedTypeKind)+++-- | For a type 'm', emit the constraint 'Quote m'.+emitQuoteWanted :: Type -> TcM EvVar+emitQuoteWanted m_var =  do+        quote_con <- tcLookupTyCon quoteClassName+        emitWantedEvVar BracketOrigin $+          mkTyConApp quote_con [m_var]+ ----------------tcBrackTy :: HsBracket GhcRn -> TcM TcType-tcBrackTy (VarBr {})  = tcMetaTy nameTyConName-                                           -- Result type is Var (not Q-monadic)-tcBrackTy (ExpBr {})  = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)-tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)-tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]-tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)-tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL"-tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr"-tcBrackTy (XBracket nec) = noExtCon nec+-- | Compute the expected type of a quotation, and also the QuoteWrapper in+-- the case where it is an overloaded quotation. All quotation forms are+-- overloaded aprt from Variable quotations ('foo)+brackTy :: HsBracket GhcRn -> TcM (Maybe QuoteWrapper, Type)+brackTy b =+  let mkTy n = do+        -- New polymorphic type variable for the bracket+        m_var <- mkTyVarTy <$> mkMetaTyVar+        -- Emit a Quote constraint for the bracket+        ev_var <- emitQuoteWanted m_var+        -- Construct the final expected type of the quote, for example+        -- m Exp or m Type+        final_ty <- mkAppTy m_var <$> tcMetaTy n+        -- Return the evidence variable and metavariable to be used during+        -- desugaring.+        let wrapper = QuoteWrapper ev_var m_var+        return (Just wrapper, final_ty)+  in+  case b of+    (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName+                                           -- Result type is Var (not Quote-monadic)+    (ExpBr {})  -> mkTy expTyConName  -- Result type is m Exp+    (TypBr {})  -> mkTy typeTyConName -- Result type is m Type+    (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]+    (PatBr {})  -> mkTy patTyConName  -- Result type is m Pat+    (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"+    (TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"+    (XBracket nec) -> noExtCon nec  ----------------tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice-tcPendingSplice (PendingRnSplice flavour splice_name expr)-  = do { res_ty <- tcMetaTy meta_ty_name-       ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)+-- | Typechecking a pending splice from a untyped bracket+tcPendingSplice :: TcType -- Metavariable for the expected overall type of the+                          -- quotation.+                -> PendingRnSplice+                -> TcM PendingTcSplice+tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)+  -- See Note [Typechecking Overloaded Quotes]+  = do { meta_ty <- tcMetaTy meta_ty_name+         -- Expected type of splice, e.g. m Exp+       ; let expected_type = mkAppTy m_var meta_ty+       ; expr' <- tcPolyExpr expr expected_type        ; return (PendingTcSplice splice_name expr') }   where      meta_ty_name = case flavour of-                       UntypedExpSplice  -> expQTyConName-                       UntypedPatSplice  -> patQTyConName-                       UntypedTypeSplice -> typeQTyConName-                       UntypedDeclSplice -> decsQTyConName+                       UntypedExpSplice  -> expTyConName+                       UntypedPatSplice  -> patTyConName+                       UntypedTypeSplice -> typeTyConName+                       UntypedDeclSplice -> decsTyConName  ------------------ Takes a tau and returns the type Q (TExp tau)-tcTExpTy :: TcType -> TcM TcType-tcTExpTy exp_ty+-- Takes a m and tau and returns the type m (TExp tau)+tcTExpTy :: TcType -> TcType -> TcM TcType+tcTExpTy m_ty exp_ty   = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)-       ; q    <- tcLookupTyCon qTyConName        ; texp <- tcLookupTyCon tExpTyConName        ; let rep = getRuntimeRep exp_ty-       ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }+       ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) }   where     err_msg ty       = vcat [ text "Illegal polytype:" <+> ppr ty@@ -401,7 +468,7 @@                incremented by brackets [| |]                incremented by name-quoting 'f -When a variable is used, we compare+* When a variable is used, checkWellStaged compares         bind:  binding level, and         use:   current level at usage site @@ -427,8 +494,46 @@   For example:            f = ...            g1 = $(map ...)         is OK-           g2 = $(f ...)           is not OK; because we havn't compiled f yet+           g2 = $(f ...)           is not OK; because we haven't compiled f yet +Note [Typechecking Overloaded Quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The main function for typechecking untyped quotations is `tcUntypedBracket`.++Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`.+When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and+emit a constraint `Quote m`. All this is done in the `brackTy` function.+`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc).++The meta variable and the constraint evidence variable are+returned together in a `QuoteWrapper` and then passed along to two further places+during compilation:++1. Typechecking nested splices (immediately in tcPendingSplice)+2. Desugaring quotations (see DsMeta)++`tcPendingSplice` takes the `m` type variable as an argument and checks+each nested splice against this variable `m`. During this+process the variable `m` can either be fixed to a specific value or further constrained by the+nested splices.++Once we have checked all the nested splices, the quote type is checked against+the expected return type.++The process is very simple and like typechecking a list where the quotation is+like the container and the splices are the elements of the list which must have+a specific type.++After the typechecking process is completed, the evidence variable for `Quote m`+and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline+and used when desugaring quotations.++Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored+in the `PendingStuff` as the nested splices are gathered up in a different way+to untyped splices. Untyped splices are found in the renamer but typed splices are+not typechecked and extracted until during typechecking.+ -}  -- | We only want to produce warnings for TH-splices if the user requests so.@@ -493,7 +598,7 @@  'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local environment (see Note [Delaying modFinalizers in untyped splices] in-"RnSplice"). Thus after executing the splice, we move the finalizers to the+GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the finalizer list in the global environment and set them to use the current local environment (with 'addModFinalizersWithLclEnv'). @@ -503,15 +608,17 @@                 -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)     -- See Note [How brackets and nested splices are handled]     -- A splice inside brackets-tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty+tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty   = do { res_ty <- expTypeToType res_ty        ; let rep = getRuntimeRep res_ty-       ; meta_exp_ty <- tcTExpTy res_ty+       ; meta_exp_ty <- tcTExpTy m_var res_ty        ; expr' <- setStage pop_stage $                   setConstraintVar lie_var $                   tcMonoExpr expr (mkCheckExpType meta_exp_ty)        ; untypeq <- tcLookupId unTypeQName-       ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'+       ; let expr'' = mkHsApp+                        (mkLHsWrap (applyQuoteWrapper q)+                          (nlHsTyApp untypeq [rep, res_ty])) expr'        ; ps <- readMutVar ps_var        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) @@ -526,7 +633,9 @@   = do { -- Typecheck the expression,          -- making sure it has type Q (T res_ty)          res_ty <- expTypeToType res_ty-       ; meta_exp_ty <- tcTExpTy res_ty+       ; q_type <- tcMetaTy qTyConName+       -- Top level splices must still be of type Q (TExp a)+       ; meta_exp_ty <- tcTExpTy q_type res_ty        ; q_expr <- tcTopSpliceExpr Typed $                           tcMonoExpr expr (mkCheckExpType meta_exp_ty)        ; lcl_env <- getLclEnv@@ -817,7 +926,7 @@                 -- including, say, a pattern-match exception in the code we are running                 --                 -- We also do the TH -> HS syntax conversion inside the same-                -- exception-cacthing thing so that if there are any lurking+                -- exception-catching thing so that if there are any lurking                 -- exceptions in the data structure returned by hval, we'll                 -- encounter them inside the try                 --@@ -926,7 +1035,7 @@   * 'qReport' forces the message to ensure any exception hidden in unevaluated    thunk doesn't get into the bag of errors. Otherwise the following splice-   will triger panic (#8987):+   will trigger panic (#8987):         $(fail undefined)    See also Note [Concealed TH exceptions] @@ -1089,7 +1198,7 @@       RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)       -- This case happens only if a splice is executed and the caller does       -- not set the 'ThStage' to 'RunSplice' to collect finalizers.-      -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+      -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.       _ ->         pprPanic "addModFinalizer was called when no finalizers were collected"                  (ppr th_stage)
compiler/typecheck/TcTyClsDecls.hs view
@@ -10,6 +10,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcTyClsDecls (         tcTyAndClassDecls, @@ -43,7 +45,7 @@ import TcMType import TysWiredIn ( unitTy, makeRecoveryTyCon ) import TcType-import RnEnv( lookupConstructorFields )+import GHC.Rename.Env( lookupConstructorFields ) import FamInst import FamInstEnv import Coercion@@ -462,7 +464,7 @@      TcTyCons, again overriding the promotion-error bindings.       But note that the data constructor promotion errors are still in place-     so that (in our example) a use of MkB will sitll be signalled as+     so that (in our example) a use of MkB will still be signalled as      an error.    4. Typecheck the decls.@@ -593,7 +595,7 @@              -- Running example in Note [Inferring kinds for type declarations]              --    spec_req_prs = [ ("k1",kk1), ("a", (aa::kk1))              --                   , ("k2",kk2), ("x", (xx::kk2))]-             -- where "k1" dnotes the Name k1, and kk1, aa, etc are MetaTyVars,+             -- where "k1" denotes the Name k1, and kk1, aa, etc are MetaTyVars,              -- specifically TyVarTvs         -- Step 0: zonk and skolemise the Specified and Required binders@@ -837,7 +839,7 @@  * Step 1: inferInitialKinds, and in particular kcInferDeclHeader.   Make a unification variable for each of the Required and Specified-  type varialbes in the header.+  type variables in the header.    Record the connection between the Names the user wrote and the   fresh unification variables in the tcTyConScopedTyVars field@@ -862,7 +864,7 @@           S :: kk3 -> * -> kk4 -> *  * Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and-  T, with these monomophic kinds.  Now kind-check the declarations,+  T, with these monomorphic kinds.  Now kind-check the declarations,   and solve the resulting equalities.  The goal here is to discover   constraints on all these unification variables. @@ -1468,7 +1470,7 @@ It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon with tyConResKind of Type -> forall k. k -> Type.  Even that is fine: the splitPiTys will look past the forall.  But I'm bothered about-what if the type "in the corner" metions k?  This is incredibly+what if the type "in the corner" mentions k?  This is incredibly obscure but something like this could be bad:    data T a :: Type -> foral k. k -> TYPE (F k) where ... @@ -1715,7 +1717,7 @@  There's also a change in the renamer: -* In RnSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means+* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means   for a newtype to have a CUSK. This is necessary since UnliftedNewtypes   means that, for newtypes without kind signatures, we must use the field   inside the data constructor to determine the result kind.@@ -2174,7 +2176,9 @@          -- overlap done by dropDominatedAxioms        ; return fam_tc } } +#if __GLASGOW_HASKELL__ <= 810   | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker+#endif tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec  -- | Maybe return a list of Bools that say whether a type family was declared@@ -2304,7 +2308,7 @@     --     -- Note that this is only a property that data type declarations possess,     -- so one could not have, say, a data family instance in an hsig file that-    -- has kind `Bool`. Therfore, this check need only occur in the code that+    -- has kind `Bool`. Therefore, this check need only occur in the code that     -- typechecks data type declarations.     mk_permissive_kind HsigFile [] = True     mk_permissive_kind _ _ = False@@ -2355,7 +2359,7 @@              --  type family Bar x y where              --      Bar (x :: a) (y :: b) = Int              --      Bar (x :: c) (y :: d) = Bool-             -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately+             -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately     }   where     vis_arity = length (tyConVisibleTyVars tc_fam_tc)@@ -2445,10 +2449,10 @@ so visible type application etc plays no role.  So, the simple thing is-   - gather candiates from [k, a, b] and pats+   - gather candidates from [k, a, b] and pats    - quantify over them -Hence the sligtly mysterious call:+Hence the slightly mysterious call:     candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)  Simple, neat, but a little non-obvious!@@ -2516,7 +2520,7 @@        ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $                                 setXOptM LangExt.PartialTypeSignatures $                                 -- See Note [Wildcards in family instances] in-                                -- RnSource.hs+                                -- GHC.Rename.Source                                 tcInferApps typeLevelMode lhs_fun fun_ty hs_pats         ; traceTc "End tcFamTyPats }" $@@ -3371,7 +3375,7 @@    This is really bogus; now we have in scope a Class that is invalid   in some way, with unknown downstream consequences.  A better-  alterantive might be to make a fake class TyCon.  A job for another day.+  alternative might be to make a fake class TyCon.  A job for another day. -}  -------------------------@@ -3967,7 +3971,7 @@ The default implementation for enum only works for types that are instances of Generic, and for which their generic Rep type is an instance of GEnum. But clearly enum doesn't _have_ to use this implementation, so naturally, the-context for enum is allowed to be different to accomodate this. As a result,+context for enum is allowed to be different to accommodate this. As a result, when we validity-check default type signatures, we ignore contexts completely.  Note that when checking whether two type signatures match, we must take care to
compiler/typecheck/TcTyDecls.hs view
@@ -14,6 +14,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcTyDecls(         RolesInfo,         inferRoles,@@ -789,7 +791,7 @@      --     we need the correct visibility: these default methods are      --     used in code generated by the fill-in for missing      --     methods in instances (TcInstDcls.mkDefMethBind), and-     --     then typechecked.  So we need the right visibilty info+     --     then typechecked.  So we need the right visibility info      --     (#13998)  {-@@ -1026,6 +1028,6 @@                 T1 (x::b) -> x  The scrutinee of the case has type :R7T (Maybe b), which can be-gotten by appying the eq_spec to the univ_tvs of the data con.+gotten by applying the eq_spec to the univ_tvs of the data con.  -}
compiler/typecheck/TcTypeable.hs view
@@ -15,7 +15,7 @@ import GhcPrelude  import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )-import IfaceEnv( newGlobalBinder )+import GHC.Iface.Env( newGlobalBinder ) import TyCoRep( Type(..), TyLit(..) ) import TcEnv import TcEvidence ( mkWpTyApps )@@ -83,7 +83,7 @@    to use for these M.$tcT "tycon rep names". Note that these must be    treated as "never exported" names by Backpack (see    Note [Handling never-exported TyThings under Backpack]). Consequently-   they get slightly special treatment in RnModIface.rnIfaceDecl.+   they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl.  3. Record the TyConRepName in T's TyCon, including for promoted    data and type constructors, and kinds like * and #.@@ -344,7 +344,7 @@ -- The majority of the types we need here are contained in 'primTyCons'. -- However, not all of them: in particular unboxed tuples are absent since we -- don't want to include them in the original name cache. See--- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.+-- Note [Built-in syntax and the OrigNameCache] in GHC.Iface.Env for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat     [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]
compiler/typecheck/TcUnify.hs view
@@ -9,6 +9,9 @@ {-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections,     ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ module TcUnify (   -- Full-blown subsumption   tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,@@ -960,7 +963,7 @@     (let { f :: forall a. a -> a; f x = x } in f) @Int     We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)-   And we don't want to instantite the type of 'f' when we reach it,+   And we don't want to instantiate the type of 'f' when we reach it,    else the outer visible type application won't work  2. :type +v. When we say@@ -1137,7 +1140,7 @@                 text "given"       <+> ppr given,                 text "inst type"   <+> ppr rho' ] -        -- Generally we must check that the "forall_tvs" havn't been constrained+        -- Generally we must check that the "forall_tvs" haven't been constrained         -- The interesting bit here is that we must include the free variables         -- of the expected_ty.  Here's an example:         --       runST (newVar True)@@ -2152,7 +2155,7 @@ We don't want to reject it because of the forall in beta's kind, but (see Note [Occurrence checking: look inside kinds]) we do need to look in beta's kind.  So we carry a flag saying if a 'forall'-is OK, and sitch the flag on when stepping inside a kind.+is OK, and switch the flag on when stepping inside a kind.  Why is it OK?  Why does it not count as impredicative polymorphism? The reason foralls are bad is because we reply on "seeing" foralls
compiler/typecheck/TcValidity.hs view
@@ -5,6 +5,9 @@  {-# LANGUAGE CPP, TupleSections, ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ module TcValidity (   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,   checkValidTheta,@@ -43,8 +46,8 @@ import TcOrigin  -- others:-import IfaceType( pprIfaceType, pprIfaceTypeApp )-import ToIface  ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )+import GHC.Iface.Type   ( pprIfaceType, pprIfaceTypeApp )+import GHC.CoreToIface  ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) import GHC.Hs           -- HsType import TcRnMonad        -- TcType, amongst others import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv )@@ -130,7 +133,7 @@  This test is very conveniently implemented by calling     tcSubType <type> <type>-This neatly takes account of the functional dependecy stuff above,+This neatly takes account of the functional dependency stuff above, and implicit parameter (see Note [Implicit parameters and ambiguity]). And this is what checkAmbiguity does. @@ -170,7 +173,7 @@ this *does* catch function f above. too.  Concerning (a) the ambiguity check is only used for *user* types, not-for types coming from inteface files.  The latter can legitimately+for types coming from interface files.  The latter can legitimately have ambiguous types. Example     class S a where s :: a -> (Int,Int)@@ -275,7 +278,7 @@    There is also an implementation reason (#11608).  In the RHS of   a type synonym we don't (currently) instantiate 'a' and 'b' with-  TcTyVars before calling checkValidType, so we get asertion failures+  TcTyVars before calling checkValidType, so we get assertion failures   from doing an ambiguity check on a type with TyVars in it.  Fixing this   would not be hard, but let's wait till there's a reason. @@ -972,7 +975,7 @@ which is fine.  IMPORTANT: suppose T is a type synonym.  Then we must do validity-checking on an appliation (T ty1 ty2)+checking on an application (T ty1 ty2)          *either* before expansion (i.e. check ty1, ty2)         *or* after expansion (i.e. expand T ty1 ty2, and then check)@@ -1971,7 +1974,7 @@ Are these OK?   type family F a   instance F a    => C (Maybe [a]) where ...-  intance C (F a) => C [[[a]]]     where ...+  instance C (F a) => C [[[a]]]     where ...  No: the type family in the instance head might blow up to an arbitrarily large type, depending on how 'a' is instantiated.@@ -2320,7 +2323,7 @@     tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan      -- For check_match, bind_me, see-    -- Note [Matching in the consistent-instantation check]+    -- Note [Matching in the consistent-instantiation check]     check_match :: [(Type,Type,ArgFlag)] -> TcM ()     check_match triples = go emptyTCvSubst emptyTCvSubst triples @@ -2421,7 +2424,7 @@ position, as `T` is not an injective type constructor, so we do not count that. Similarly for the `a` in `ConstType a`. -Note [Matching in the consistent-instantation check]+Note [Matching in the consistent-instantiation check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Matching the class-instance header to family-instance tyvars is tricker than it sounds.  Consider (#13972)
compiler/utils/GraphBase.hs view
@@ -87,7 +87,7 @@         -- | Colors that cannot be used by this node.         , nodeExclusions        :: UniqSet color -        -- | Colors that this node would prefer to be, in decending order.+        -- | Colors that this node would prefer to be, in descending order.         , nodePreference        :: [color]          -- | Neighbors that this node would like to be colored the same as.
compiler/utils/GraphColor.hs view
@@ -3,6 +3,8 @@ --      the node keys, nodes and colors. -- +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module GraphColor (         module GraphBase,         module GraphOps,@@ -76,7 +78,7 @@         --      We need to apply all the coalescences found by the scanner to the original         --      graph before doing assignColors.         ---        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalecing+        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalescing         --      to force all the (conservative) coalescences found during scanning.         --         (graph_scan_coalesced, _)
compiler/utils/GraphOps.hs view
@@ -1,6 +1,8 @@ -- | Basic operations on graphs. -- +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module GraphOps (         addNode,        delNode,        getNode,       lookupNode,     modNode,         size,@@ -233,7 +235,7 @@         = foldr (addExclusion u getClass) graph colors  --- | Add a coalescence edge to the graph, creating nodes if requried.+-- | Add a coalescence edge to the graph, creating nodes if required. --      It is considered adventageous to assign the same color to nodes in a coalesence. addCoalesce         :: Uniquable k
− compiler/utils/Stream.hs 
@@ -1,135 +0,0 @@--- ----------------------------------------------------------------------------------- (c) The University of Glasgow 2012------ Monadic streams------ ------------------------------------------------------------------------------module Stream (-    Stream(..), yield, liftIO,-    collect, collect_, consume, fromList,-    Stream.map, Stream.mapM, Stream.mapAccumL, Stream.mapAccumL_-  ) where--import GhcPrelude--import Control.Monad---- |--- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence--- of elements of type @a@ followed by a result of type @b@.------ More concretely, a value of type @Stream m a b@ can be run using @runStream@--- in the Monad @m@, and it delivers either------  * the final result: @Left b@, or---  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@---    is a computation to get the rest of the stream.------ Stream is itself a Monad, and provides an operation 'yield' that--- produces a new element of the stream.  This makes it convenient to turn--- existing monadic computations into streams.------ The idea is that Stream is useful for making a monadic computation--- that produces values from time to time.  This can be used for--- knitting together two complex monadic operations, so that the--- producer does not have to produce all its values before the--- consumer starts consuming them.  We make the producer into a--- Stream, and the consumer pulls on the stream each time it wants a--- new value.----newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }--instance Monad f => Functor (Stream f a) where-  fmap = liftM--instance Monad m => Applicative (Stream m a) where-  pure a = Stream (return (Left a))-  (<*>) = ap--instance Monad m => Monad (Stream m a) where--  Stream m >>= k = Stream $ do-                r <- m-                case r of-                  Left b        -> runStream (k b)-                  Right (a,str) -> return (Right (a, str >>= k))--yield :: Monad m => a -> Stream m a ()-yield a = Stream (return (Right (a, return ())))--liftIO :: IO a -> Stream IO b a-liftIO io = Stream $ io >>= return . Left---- | Turn a Stream into an ordinary list, by demanding all the elements.-collect :: Monad m => Stream m a () -> m [a]-collect str = go str []- where-  go str acc = do-    r <- runStream str-    case r of-      Left () -> return (reverse acc)-      Right (a, str') -> go str' (a:acc)---- | Turn a Stream into an ordinary list, by demanding all the elements.-collect_ :: Monad m => Stream m a r -> m ([a], r)-collect_ str = go str []- where-  go str acc = do-    r <- runStream str-    case r of-      Left r -> return (reverse acc, r)-      Right (a, str') -> go str' (a:acc)--consume :: Monad m => Stream m a b -> (a -> m ()) -> m b-consume str f = do-    r <- runStream str-    case r of-      Left ret -> return ret-      Right (a, str') -> do-        f a-        consume str' f---- | Turn a list into a 'Stream', by yielding each element in turn.-fromList :: Monad m => [a] -> Stream m a ()-fromList = mapM_ yield---- | Apply a function to each element of a 'Stream', lazily-map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x-map f str = Stream $ do-   r <- runStream str-   case r of-     Left x -> return (Left x)-     Right (a, str') -> return (Right (f a, Stream.map f str'))---- | Apply a monadic operation to each element of a 'Stream', lazily-mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x-mapM f str = Stream $ do-   r <- runStream str-   case r of-     Left x -> return (Left x)-     Right (a, str') -> do-        b <- f a-        return (Right (b, Stream.mapM f str'))---- | analog of the list-based 'mapAccumL' on Streams.  This is a simple--- way to map over a Stream while carrying some state around.-mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()-          -> Stream m b c-mapAccumL f c str = Stream $ do-  r <- runStream str-  case r of-    Left  () -> return (Left c)-    Right (a, str') -> do-      (c',b) <- f c a-      return (Right (b, mapAccumL f c' str'))--mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r-           -> Stream m b (c, r)-mapAccumL_ f c str = Stream $ do-  r <- runStream str-  case r of-    Left  r -> return (Left (c, r))-    Right (a, str') -> do-      (c',b) <- f c a-      return (Right (b, mapAccumL_ f c' str'))
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20200102+version: 0.20200201 license: BSD3 license-file: LICENSE category: Development@@ -46,7 +46,7 @@     includes/CodeGen.Platform.hs     compiler/HsVersions.h     compiler/Unique.h-tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.3+tested-with: GHC==8.8.2, GHC==8.6.5, GHC==8.4.4 source-repository head     type: git     location: git@github.com:digital-asset/ghc-lib.git@@ -82,7 +82,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 0.20200102+        ghc-lib-parser == 0.20200201     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -130,17 +130,14 @@         compiler/backpack         compiler/coreSyn         compiler/deSugar-        compiler/hieFile         compiler/llvmGen         compiler/prelude         compiler/stranal-        compiler/rename         compiler/iface         compiler/utils         libraries/ghci         compiler/ghci         compiler/main-        compiler/cmm         compiler/.         compiler     autogen-modules:@@ -160,7 +157,6 @@         Class,         CliOption,         CmdLineParser,-        CmmType,         CoAxiom,         Coercion,         ConLike,@@ -204,6 +200,19 @@         FiniteMap,         ForeignCall,         GHC.BaseDir,+        GHC.Cmm,+        GHC.Cmm.BlockId,+        GHC.Cmm.CLabel,+        GHC.Cmm.Dataflow.Block,+        GHC.Cmm.Dataflow.Collections,+        GHC.Cmm.Dataflow.Graph,+        GHC.Cmm.Dataflow.Label,+        GHC.Cmm.Expr,+        GHC.Cmm.MachOp,+        GHC.Cmm.Node,+        GHC.Cmm.Switch,+        GHC.Cmm.Type,+        GHC.CoreToIface,         GHC.Exts.Heap,         GHC.Exts.Heap.ClosureTypes,         GHC.Exts.Heap.Closures,@@ -228,12 +237,25 @@         GHC.Hs.Types,         GHC.Hs.Utils,         GHC.HsToCore.PmCheck.Types,+        GHC.Iface.Syntax,+        GHC.Iface.Type,         GHC.LanguageExtensions,         GHC.LanguageExtensions.Type,         GHC.Lexeme,         GHC.PackageDb,         GHC.Platform,+        GHC.Platform.ARM,+        GHC.Platform.ARM64,+        GHC.Platform.NoRegs,+        GHC.Platform.PPC,+        GHC.Platform.Regs,+        GHC.Platform.S390X,+        GHC.Platform.SPARC,+        GHC.Platform.X86,+        GHC.Platform.X86_64,+        GHC.Runtime.Layout,         GHC.Serialized,+        GHC.Stg.Syntax,         GHC.Types.RepType,         GHC.UniqueSubdir,         GHC.Version,@@ -252,8 +274,6 @@         IOEnv,         Id,         IdInfo,-        IfaceSyn,-        IfaceType,         InstEnv,         InteractiveEvalTypes,         Json,@@ -285,7 +305,6 @@         OptCoercion,         OrdList,         Outputable,-        PackageConfig,         Packages,         Pair,         Panic,@@ -304,10 +323,13 @@         PrimOp,         RdrHsSyn,         RdrName,+        Reg,+        RegClass,         Rules,         Settings,         SizedSeq,         SrcLoc,+        Stream,         StringBuffer,         SysTools.BaseDir,         SysTools.Terminal,@@ -316,7 +338,6 @@         TcOrigin,         TcRnTypes,         TcType,-        ToIface,         ToolSettings,         TrieMap,         TyCoFVs,@@ -335,6 +356,7 @@         UniqSet,         UniqSupply,         Unique,+        UnitInfo,         Util,         Var,         VarEnv,@@ -344,9 +366,6 @@         Ar         AsmCodeGen         AsmUtils-        BinIface-        Bitmap-        BlockId         BlockLayout         BuildTyCl         ByteCodeAsm@@ -355,37 +374,13 @@         ByteCodeItbls         ByteCodeLink         CFG-        CLabel         CPrim         CSE         CallArity         ClsInst-        Cmm-        CmmBuildInfoTables-        CmmCallConv-        CmmCommonBlockElim-        CmmContFlowOpt-        CmmExpr-        CmmImplementSwitchPlans-        CmmInfo-        CmmLayoutStack-        CmmLex-        CmmLint-        CmmLive-        CmmMachOp-        CmmMonad-        CmmNode-        CmmOpt-        CmmParse-        CmmPipeline-        CmmProcPoint-        CmmSink-        CmmSwitch-        CmmUtils         CodeOutput         CoreLint         Coverage-        Debug         Debugger         Desugar         DmdAnal@@ -419,23 +414,63 @@         Format         FunDeps         GHC+        GHC.Cmm.CallConv+        GHC.Cmm.CommonBlockElim+        GHC.Cmm.ContFlowOpt+        GHC.Cmm.Dataflow+        GHC.Cmm.DebugBlock+        GHC.Cmm.Graph+        GHC.Cmm.Info+        GHC.Cmm.Info.Build+        GHC.Cmm.LayoutStack+        GHC.Cmm.Lexer+        GHC.Cmm.Lint+        GHC.Cmm.Liveness+        GHC.Cmm.Monad+        GHC.Cmm.Opt+        GHC.Cmm.Parser+        GHC.Cmm.Pipeline+        GHC.Cmm.Ppr+        GHC.Cmm.Ppr.Decl+        GHC.Cmm.Ppr.Expr+        GHC.Cmm.ProcPoint+        GHC.Cmm.Sink+        GHC.Cmm.Switch.Implement+        GHC.Cmm.Utils+        GHC.CmmToC         GHC.CoreToStg         GHC.CoreToStg.Prep+        GHC.Data.Bitmap         GHC.HandleEncoding         GHC.Hs.Dump         GHC.HsToCore.PmCheck         GHC.HsToCore.PmCheck.Oracle         GHC.HsToCore.PmCheck.Ppr-        GHC.Platform.ARM-        GHC.Platform.ARM64+        GHC.Iface.Binary+        GHC.Iface.Env+        GHC.Iface.Ext.Ast+        GHC.Iface.Ext.Binary+        GHC.Iface.Ext.Debug+        GHC.Iface.Ext.Types+        GHC.Iface.Ext.Utils+        GHC.Iface.Load+        GHC.Iface.Rename+        GHC.Iface.Tidy+        GHC.Iface.Utils+        GHC.IfaceToCore         GHC.Platform.Host-        GHC.Platform.NoRegs-        GHC.Platform.PPC-        GHC.Platform.Regs-        GHC.Platform.S390X-        GHC.Platform.SPARC-        GHC.Platform.X86-        GHC.Platform.X86_64+        GHC.Rename.Binds+        GHC.Rename.Doc+        GHC.Rename.Env+        GHC.Rename.Expr+        GHC.Rename.Fixity+        GHC.Rename.Names+        GHC.Rename.Pat+        GHC.Rename.Source+        GHC.Rename.Splice+        GHC.Rename.Types+        GHC.Rename.Unbound+        GHC.Rename.Utils         GHC.Settings         GHC.Stg.CSE         GHC.Stg.FVs@@ -446,7 +481,6 @@         GHC.Stg.Pipeline         GHC.Stg.Stats         GHC.Stg.Subst-        GHC.Stg.Syntax         GHC.Stg.Unarise         GHC.StgToCmm         GHC.StgToCmm.ArgRep@@ -483,19 +517,8 @@         GraphColor         GraphOps         GraphPpr-        HieAst-        HieBin-        HieDebug-        HieTypes-        HieUtils-        Hoopl.Block-        Hoopl.Collections-        Hoopl.Dataflow-        Hoopl.Graph-        Hoopl.Label         HscMain         HscStats-        IfaceEnv         Inst         Instruction         InteractiveEval@@ -514,12 +537,9 @@         LlvmCodeGen.Ppr         LlvmCodeGen.Regs         LlvmMangler-        LoadIface         Match         MatchCon         MatchLit-        MkGraph-        MkIface         NCGMonad         NameShape         PIC@@ -530,14 +550,9 @@         PPC.RegInfo         PPC.Regs         PprBase-        PprC-        PprCmm-        PprCmmDecl-        PprCmmExpr         PprTyThing         PrelInfo         ProfInit-        Reg         RegAlloc.Graph.ArchBase         RegAlloc.Graph.ArchX86         RegAlloc.Graph.Coalesce@@ -559,23 +574,8 @@         RegAlloc.Linear.X86.FreeRegs         RegAlloc.Linear.X86_64.FreeRegs         RegAlloc.Liveness-        RegClass-        RnBinds-        RnEnv-        RnExpr-        RnFixity-        RnHsDoc-        RnModIface-        RnNames-        RnPat-        RnSource-        RnSplice-        RnTypes-        RnUnbound-        RnUtils         RtClosureInspect         SAT-        SMRep         SPARC.AddrMode         SPARC.Base         SPARC.CodeGen@@ -603,7 +603,6 @@         Specialise         State         StaticPtrTable-        Stream         SysTools         SysTools.ExtraObj         SysTools.Info@@ -634,7 +633,6 @@         TcHoleErrors         TcHsSyn         TcHsType-        TcIface         TcInstDcls         TcInteract         TcMType@@ -656,7 +654,6 @@         TcTypeable         TcUnify         TcValidity-        TidyPgm         UnVarGraph         UniqMap         WorkWrap
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -452,7 +452,7 @@ /* Define to 1 if you have the ANSI C header files. */ #define STDC_HEADERS 1 -/* Define to 1 if info tables are layed out next to code */+/* Define to 1 if info tables are laid out next to code */ #define TABLES_NEXT_TO_CODE 1  /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
ghc-lib/stage0/lib/ghcversion.h view
@@ -6,7 +6,7 @@ #endif  #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200101+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200131  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/llvm-passes view
@@ -1,5 +1,5 @@ [-(0, "-mem2reg -globalopt"),+(0, "-mem2reg -globalopt -lower-expect"), (1, "-O1 -globalopt"), (2, "-O2") ]
ghc-lib/stage0/lib/settings view
@@ -1,4 +1,4 @@-[("GCC extra via C opts", "-fwrapv -fno-builtin")+[("GCC extra via C opts", "") ,("C compiler command", "cc") ,("C compiler flags", "") ,("C++ compiler flags", "")
includes/CodeGen.Platform.hs view
@@ -1,5 +1,5 @@ -import CmmExpr+import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc)) import PlainPanic