packages feed

ghc-lib 0.20220601 → 0.20220701

raw patch · 73 files changed

+3757/−3183 lines, 73 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

compiler/GHC/Cmm/Parser.y view
@@ -960,6 +960,8 @@         ( "eq",         MO_Eq ),         ( "ne",         MO_Ne ),         ( "mul",        MO_Mul ),+        ( "mulmayoflo",  MO_S_MulMayOflo ),+        ( "mulmayoflou", MO_U_MulMayOflo ),         ( "neg",        MO_S_Neg ),         ( "quot",       MO_S_Quot ),         ( "rem",        MO_S_Rem ),
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -891,7 +891,7 @@          -- Signed multiply/divide         MO_Mul w          -> intOp True w (\d x y -> unitOL $ MUL d x y)-        MO_S_MulMayOflo w -> intOp True w (\d x y -> toOL [ MUL d x y, CSET d VS ])+        MO_S_MulMayOflo w -> do_mul_may_oflo w x y         MO_S_Quot w       -> intOp True w (\d x y -> unitOL $ SDIV d x y)          -- No native rem instruction. So we'll compute the following@@ -976,6 +976,46 @@                                     ,0b0111_1111, 0b1111_1110                                     ,0b1111_1111] +    -- N.B. MUL does not set the overflow flag.+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo w@W64 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        lo <- getNewRegNat II64+        hi <- getNewRegNat II64+        return $ Any (intFormat w) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+            SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+            CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL`+            CSET (OpReg w dst) NE)+    do_mul_may_oflo w x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        let tmp_w = case w of+                      W32 -> W64+                      W16 -> W32+                      W8  -> W32+                      _   -> panic "do_mul_may_oflo: impossible"+        -- This will hold the product+        tmp <- getNewRegNat (intFormat tmp_w)+        let ext_mode = case w of+                         W32 -> ESXTW+                         W16 -> ESXTH+                         W8  -> ESXTB+                         _   -> panic "do_mul_may_oflo: impossible"+            mul = case w of+                    W32 -> SMULL+                    W16 -> MUL+                    W8  -> MUL+                    _   -> panic "do_mul_may_oflo: impossible"+        return $ Any (intFormat w) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+            CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`+            CSET (OpReg w dst) NE)  -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.@@ -1580,14 +1620,34 @@     -- size we want to pack. Failure to get this right can result in pretty     -- subtle bugs, e.g. #20137. -    passArguments pack (gpReg:gpRegs) fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+    passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+      platform <- getPlatform       let w = formatToWidth format-      passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass gp argument: " <> ppr r) $ MOV (OpReg w gpReg) (OpReg w r)))+          mov+            -- Specifically, Darwin/AArch64's ABI requires that the caller+            -- sign-extend arguments which are smaller than 32-bits.+            | w < W32+            , platformCConvNeedsExtension platform+            , SignedHint <- hint+            = case w of+                W8  -> SXTB (OpReg W64 gpReg) (OpReg w r)+                W16 -> SXTH (OpReg W64 gpReg) (OpReg w r)+                _   -> panic "impossible"+            | otherwise+            = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass gp argument: " <> ppr r) mov+      passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'      -- Still have FP regs, and we want to pass an FP argument.     passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do       let w = formatToWidth format-      passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass fp argument: " <> ppr r) $ MOV (OpReg w fpReg) (OpReg w r)))+          mov = MOV (OpReg w fpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument: " <> ppr r) mov+      passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode'      -- No mor regs left to pass. Must pass on stack.     passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do@@ -1596,7 +1656,9 @@           space = if pack then bytes else 8           stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)                       | otherwise                           = stackSpace-          stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+          stackCode = code_r `snocOL`+                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str       passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)      -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.@@ -1606,7 +1668,9 @@           space = if pack then bytes else 8           stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)                       | otherwise                           = stackSpace-          stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+          stackCode = code_r `snocOL`+                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str       passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)      -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.@@ -1616,7 +1680,9 @@           space = if pack then bytes else 8           stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)                       | otherwise                           = stackSpace-          stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+          stackCode = code_r `snocOL`+                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str       passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)      passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -79,6 +79,8 @@   MSUB dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)   MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   NEG dst src              -> usage (regOp src, regOp dst)+  SMULH dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  SMULL dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)   SDIV dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)   SUB dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   UDIV dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)@@ -206,6 +208,8 @@     MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)     MUL o1 o2 o3   -> MUL (patchOp o1) (patchOp o2) (patchOp o3)     NEG o1 o2      -> NEG (patchOp o1) (patchOp o2)+    SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2)  (patchOp o3)+    SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2)  (patchOp o3)     SDIV o1 o2 o3  -> SDIV (patchOp o1) (patchOp o2) (patchOp o3)     SUB o1 o2 o3   -> SUB  (patchOp o1) (patchOp o2) (patchOp o3)     UDIV o1 o2 o3  -> UDIV (patchOp o1) (patchOp o2) (patchOp o3)@@ -559,8 +563,8 @@     -- | SMADDL ...     -- | SMNEGL ...     -- | SMSUBL ...-    -- | SMULH ...-    -- | SMULL ...+    | SMULH Operand Operand Operand+    | SMULL Operand Operand Operand     | SUB Operand Operand Operand -- rd = rn - op2     -- | SUBS ...     | UDIV Operand Operand Operand -- rd = rn ÷ rm
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -308,7 +308,7 @@   OpReg w r           -> pprReg w r   OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x   OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i-  OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <> comma <+> char '#' <> int i+  OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <+> char '#' <> int i   OpImm im          -> pprIm plat im   OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i   -- TODO: Address compuation always use registers as 64bit -- is this correct?@@ -387,6 +387,8 @@   MUL  o1 o2 o3     | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfmul"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3     | otherwise -> text "\tmul"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  SMULH o1 o2 o3 -> text "\tsmulh"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  SMULL o1 o2 o3 -> text "\tsmull"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3   NEG  o1 o2     | isFloatOp o1 && isFloatOp o2 -> text "\tfneg"  <+> pprOp platform o1 <> comma <+> pprOp platform o2     | otherwise -> text "\tneg"  <+> pprOp platform o1 <> comma <+> pprOp platform o2
compiler/GHC/Core/Opt/CSE.hs view
@@ -69,10 +69,28 @@ shadowing, but it doesn't any more (it proved too hard), so we clone as we go. We can simply add clones to the substitution already described. +A similar tricky situation is this, with x_123 and y_123 sharing the same unique: +    let x_123 = e1 in+    let y_123 = e2 in+    let foo = e1++Naively applying e1 = x_123 during CSE we would get:++    let x_123 = e1 in+    let y_123 = e2 in+    let foo = x_123++But x_123 is shadowed by y_123 and things would go terribly wrong! One more reason+why we have to substitute binders as we go so we will properly get:++    let x1 = e1 in+    let x2 = e2 in+    let foo = x1+ Note [CSE for bindings] ~~~~~~~~~~~~~~~~~~~~~~~-Let-bindings have two cases, implemented by addBinding.+Let-bindings have two cases, implemented by extendCSEnvWithBinding.  * SUBSTITUTE: applies when the RHS is a variable @@ -95,7 +113,7 @@       Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to       the substitution so that we can CSE the binding for y2. -    - Second, we use addBinding for case expression scrutinees too;+    - Second, we use extendCSEnvWithBinding for case expression scrutinees too;       see Note [CSE for case expressions]  * EXTEND THE REVERSE MAPPING: applies in all other cases@@ -136,7 +154,7 @@   case scrut_expr of x { ...alts... } This is very like a strict let-binding   let !x = scrut_expr in ...-So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a+So we use (extendCSEnvWithBinding x scrut_expr) to process scrut_expr and x, and as a result all the stuff under Note [CSE for bindings] applies directly.  For example:@@ -151,18 +169,18 @@   want to keep it as (wild1:as), but for CSE purpose that's a bad   idea. -  By using addBinding we add the binding (wild1 -> a) to the substitution,+  By using extendCSEnvWithBinding we add the binding (wild1 -> a) to the substitution,   which does exactly the right thing.    (Notice this is exactly backwards to what the simplifier does, which   is to try to replaces uses of 'a' with uses of 'wild1'.) -  This is the main reason that addBinding is called with a trivial rhs.+  This is the main reason that extendCSEnvWithBinding is called with a trivial rhs.  * Non-trivial scrutinee      case (f x) of y { pat -> ...let z = f x in ... } -  By using addBinding we'll add (f x :-> y) to the cs_map, and+  By using extendCSEnvWithBinding we'll add (f x :-> y) to the cs_map, and   thereby CSE the inner (f x) to y.  Note [CSE for INLINE and NOINLINE]@@ -336,7 +354,27 @@ We can't use cs_map for this, because the key isn't an expression of the program; it's a kind of synthetic key for recursive bindings. +Note [Separate envs for let rhs and body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Substituting occurances of the binder in the rhs with the+ renamed binder is wrong for non-recursive bindings. Why?+Consider this core. +    let {x_123 = e} in+    let {y_123 = \eta0 -> x_123} in ...++In the second line the y_123 on the lhs and x_123 on the rhs refer to different binders+even if they share the same unique.++If we apply the substitution `123 => x2_124}` to both the lhs and rhs we  will transform+`let y_123 = \eta0 -> x_123` into `let x2_124 = \eta0 -> x2_124`.+However x2_124 on the rhs is not in scope and really shouldn't have been renamed at all.+Because really this should still be x_123! In fact this exact thing happened in #21685.++To fix this we pass two different cse envs to cse_bind. One we use the cse the rhs of the binding.+And one we update with the result of cseing the rhs which we then use going forward for the+body/rest of the module.+ ************************************************************************ *                                                                      * \section{Common subexpression}@@ -351,8 +389,9 @@ cseBind toplevel env (NonRec b e)   = (env2, NonRec b2 e2)   where+    -- See Note [Separate envs for let rhs and body]     (env1, b1)       = addBinder env b-    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1+    (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1  cseBind toplevel env (Rec [(in_id, rhs)])   | noCSE in_id@@ -382,31 +421,33 @@     (env1, bndrs1) = addRecBinders env (map fst pairs)     (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) -    do_one env (pr, b1) = cse_bind toplevel env pr b1+    do_one env (pr, b1) = cse_bind toplevel env env pr b1  -- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer -- to @in_id@ (@out_id@, created from addBinder or addRecBinders), -- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) -- binding to the 'CSEnv', so that we attempt to CSE any expressions -- which are equal to @out_rhs@.-cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))-cse_bind toplevel env (in_id, in_rhs) out_id+-- We use a different env for cse on the rhs and for extendCSEnvWithBinding+-- for reasons explain in See Note [Separate envs for let rhs and body]+cse_bind :: TopLevelFlag -> CSEnv -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))+cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id   | isTopLevel toplevel, exprIsTickedString in_rhs       -- See Note [Take care with literal strings]-  = (env', (out_id', in_rhs))+  = (env_body', (out_id', in_rhs)) -  | Just arity <- isJoinId_maybe in_id+  | Just arity <- isJoinId_maybe out_id       -- See Note [Look inside join-point binders]   = let (params, in_body) = collectNBinders arity in_rhs-        (env', params') = addBinders env params+        (env', params') = addBinders env_rhs params         out_body = tryForCSE env' in_body-    in (env, (out_id, mkLams params' out_body))+    in (env_body , (out_id, mkLams params' out_body))    | otherwise-  = (env', (out_id'', out_rhs))+  = (env_body', (out_id'', out_rhs))   where-    (env', out_id') = addBinding env in_id out_id out_rhs cse_done-    (cse_done, out_rhs)  = try_for_cse env in_rhs+    (env_body', out_id') = extendCSEnvWithBinding env_body  in_id out_id out_rhs cse_done+    (cse_done, out_rhs)  = try_for_cse env_rhs in_rhs     out_id'' | cse_done  = zapStableUnfolding $                            delayInlining toplevel out_id'              | otherwise = out_id'@@ -426,7 +467,8 @@   | otherwise   = bndr -addBinding :: CSEnv            -- Includes InId->OutId cloning+extendCSEnvWithBinding+           :: CSEnv            -- Includes InId->OutId cloning            -> InVar            -- Could be a let-bound type            -> OutId -> OutExpr -- Processed binding            -> Bool             -- True <=> RHS was CSE'd and is a variable@@ -437,13 +479,14 @@ -- -- It's possible for the binder to be a type variable, -- in which case we can just substitute.-addBinding env in_id out_id rhs' cse_done-  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)-  | noCSE in_id      = (env,                              out_id)-  | use_subst        = (extendCSSubst env in_id rhs',     out_id)-  | cse_done         = (env,                              out_id)+-- See Note [CSE for bindings]+extendCSEnvWithBinding env in_id out_id rhs' cse_done+  | not (isId out_id) = (extendCSSubst env in_id rhs',     out_id)+  | noCSE out_id      = (env,                              out_id)+  | use_subst         = (extendCSSubst env in_id rhs',     out_id)+  | cse_done          = (env,                              out_id)                        -- See Note [Dealing with ticks]-  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)+  | otherwise         = (extendCSEnv env rhs' id_expr', zapped_id)   where     id_expr'  = varToCoreExpr out_id     zapped_id = zapIdUsageInfo out_id@@ -516,8 +559,25 @@   an expression   - when inserting into the cs_map (see extendCSEnv)   - when looking up in the cs_map (see call to lookupCSEnv in try_for_cse)-  Quite why only the tickishFloatble ticks, I'm not quite sure.+  Quite why only the tickishFloatable ticks, I'm not quite sure. +  AK: I think we only do this for floatable ticks since generally we don't mind them+  being less accurate as much. E.g. consider+    case e of+      C1 -> f (<tick1> e1)+      C2 -> f (<tick2> e1)+  If the ticks are (floatable) source notes nothing too bad happens if the debug info for+  both branches says the code comes from the same source location. Even if it will be inaccurate+  for one of the branches. We should probably still consider this worthwhile.+  However if the ticks are cost centres we really don't want the cost of both branches to be+  attributed to the same cost centre. Because a user might explicitly have inserted different+  cost centres in order to distinguish between evaluations resulting from the two different branches.+  e.g. something like this:+    case e of+      C1 -> f ({ SCC "evalAlt1"} e1)+      C1 -> f ({ SCC "evalAlt2"} e1)+  But it's still a bit suspicious.+ * If we get a hit in cs_map, we wrap the result in the ticks from the   thing we are looking up (see try_for_cse) @@ -525,7 +585,7 @@   let x = tick t1 (tick t2 e) with   let x = tick t1 (tick t2 y)-where 'y' is the variable that 'e' maps to.  Now consider addBinding for+where 'y' is the variable that 'e' maps to.  Now consider extendCSEnvWithBinding for the binding for 'x':  * We can't use SUBSTITUTE because those ticks might not be trivial (we@@ -536,7 +596,7 @@   to the cs_map. Remember we strip off the ticks, so that would amount   to adding y :-> x, very silly. -TL;DR: we do neither; hence the cse_done case in addBinding.+TL;DR: we do neither; hence the cse_done case in extendCSEnvWithBinding.   Note [Delay inlining after CSE]@@ -662,8 +722,8 @@       -- in cse_alt may mean that a dead case binder       -- becomes alive, and Lint rejects that     (env1, bndr2)    = addBinder env bndr1-    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 cse_done-         -- addBinding: see Note [CSE for case expressions]+    (alt_env, bndr3) = extendCSEnvWithBinding env1 bndr bndr2 scrut1 cse_done+         -- extendCSEnvWithBinding: see Note [CSE for case expressions]      con_target :: OutExpr     con_target = lookupSubst alt_env bndr@@ -791,9 +851,12 @@             -- The substitution variables to             -- /trivial/ OutExprs, not arbitrary expressions -       , cs_map   :: CoreMap OutExpr   -- The reverse mapping+       , cs_map   :: CoreMap OutExpr+            -- The "reverse" mapping.             -- Maps a OutExpr to a /trivial/ OutExpr             -- The key of cs_map is stripped of all Ticks+            -- It maps arbitrary expressions to trivial expressions+            -- representing the same value. E.g @C a b@ to @x1@.         , cs_rec_map :: CoreMap OutExpr             -- See Note [CSE for recursive bindings]@@ -807,6 +870,7 @@ lookupCSEnv (CS { cs_map = csmap }) expr   = lookupCoreMap csmap expr +-- | @extendCSEnv env e triv_expr@ will replace any occurrence of @e@ with @triv_expr@ going forward. extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv extendCSEnv cse expr triv_expr   = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -10,7 +10,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.Flags ( DumpFlag (..) )  import GHC.Builtin.Names ( runRWKey ) @@ -398,8 +398,10 @@   where     init_sig id       -- See Note [CPR for data structures]-      | isDataStructure id = topCprSig-      | otherwise          = mkCprSig 0 botCpr+      -- Don't set the sig to bottom in this case, because cprAnalBind won't+      -- update it to something reasonable. Result: Assertion error in WW+      | isDataStructure id || isDFunId id = topCprSig+      | otherwise                         = mkCprSig 0 botCpr     -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal     orig_virgin = ae_virgin orig_env     init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]@@ -464,10 +466,10 @@   | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.   = (id,  rhs,  extendSigEnv env id topCprSig)   -- See Note [CPR for data structures]-  | isDataStructure id-  = (id,  rhs,  env) -- Data structure => no code => no need to analyse rhs+  | isDataStructure id -- Data structure => no code => no need to analyse rhs+  = (id,  rhs,  env)   | otherwise-  = (id', rhs', env')+  = (id `setIdCprSig` sig',       rhs', env')   where     (rhs_ty, rhs')  = cprAnal env rhs     -- possibly trim thunk CPR info@@ -481,7 +483,6 @@     -- See Note [The OPAQUE pragma and avoiding the reboxing of results]     sig' | isOpaquePragma (idInlinePragma id) = topCprSig          | otherwise                          = sig-    id'  = setIdCprSig id sig'     env' = extendSigEnv env id sig'      -- See Note [CPR for thunks]
compiler/GHC/Core/Opt/FloatOut.hs view
@@ -18,7 +18,7 @@ import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) -import GHC.Driver.Session+import GHC.Driver.Flags  ( DumpFlag (..) ) import GHC.Utils.Logger import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,                            isJoinId, isJoinId_maybe )
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -13,21 +13,22 @@ import GHC.Driver.Session import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env+import GHC.Driver.Config.Core.Lint ( endPass, lintPassResult ) import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )+import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways  ( hasWay, Way(WayProf) )  import GHC.Core import GHC.Core.Opt.CSE  ( cseProgram ) import GHC.Core.Rules   ( mkRuleBase,                           extendRuleBaseList, ruleCheckProgram, addRuleInfo,-                          getRules, initRuleOpts )+                          getRules ) import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize ) import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )-import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,-                          lintAnnots )+import GHC.Core.Lint    ( dumpPassResult, lintAnnots ) import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) import GHC.Core.Opt.Simplify.Env@@ -135,6 +136,7 @@     phases        = simplPhases        dflags     max_iter      = maxSimplIterations dflags     rule_check    = ruleCheck          dflags+    float_enable  = floatEnable        dflags     const_fold    = gopt Opt_CoreConstantFolding          dflags     call_arity    = gopt Opt_CallArity                    dflags     exitification = gopt Opt_Exitification                dflags@@ -176,6 +178,7 @@                           , sm_inline       = True                           , sm_case_case    = True                           , sm_pre_inline   = pre_inline_on+                          , sm_float_enable = float_enable                           }      simpl_phase phase name iter@@ -549,7 +552,6 @@     CoreDesugarOpt            -> pprPanic "doCorePass" (ppr pass)     CoreTidy                  -> pprPanic "doCorePass" (ppr pass)     CorePrep                  -> pprPanic "doCorePass" (ppr pass)-    CoreOccurAnal             -> pprPanic "doCorePass" (ppr pass)  {- ************************************************************************
compiler/GHC/Core/Opt/Simplify.hs view
@@ -43,9 +43,11 @@                           , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )+import GHC.Core.Rules   ( lookupRule, getRules ) import GHC.Core.Multiplicity +import GHC.Driver.Config.Core.Rules ( initRuleOpts )+ import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 import GHC.Types.SourceText import GHC.Types.Id@@ -76,7 +78,6 @@  import Control.Monad - {- The guts of the simplifier is in this module, but the driver loop for the simplifier is in GHC.Core.Opt.Pipeline@@ -259,9 +260,11 @@              -> [(InId, InExpr)]              -> SimplM (SimplFloats, SimplEnv) simplRecBind env0 bind_cxt pairs0-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0-        ; (rec_floats, env1) <- go env_with_info triples-        ; return (mkRecFloats rec_floats, env1) }+  = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0+        ; let new_bndrs = map sndOf3 triples+        ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->+            go env triples+        ; return (mkRecFloats rec_floats, env2) }   where     add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))         -- Add the (substituted) rules to the binder@@ -718,7 +721,7 @@         -- Finally, decide whether or not to float        ; let all_floats = rhs_floats1 `addLetFloats` anf_floats-       ; if doFloatFromRhs top_lvl is_rec strict_bind all_floats rhs2+       ; if doFloatFromRhs (sm_float_enable $ seMode env) top_lvl is_rec strict_bind all_floats rhs2          then -- Float!               do { tick LetFloatFromLet                  ; return (all_floats, rhs2) }@@ -1701,8 +1704,9 @@ -- Historically this had a special case for when a lambda-binder -- could have a stable unfolding; -- see Historical Note [Case binders and join points]--- But now it is much simpler!-simplLamBndr env bndr = simplBinder env bndr+-- But now it is much simpler! We now only remove unfoldings.+-- See Note [Never put `OtherCon` unfoldings on lambda binders]+simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)  simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs@@ -2902,8 +2906,14 @@   | isTyCoVar case_bndr    -- Respect GHC.Core   = isTyCoArg scrut        -- Note [Core type and coercion invariant] -  | isUnliftedType (idType case_bndr)-    -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase)+  | isUnliftedType (exprType scrut)+    -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).+    -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'+    -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].+    -- Using `exprType` is typically cheap becuase `scrut` is typically a variable.+    -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts+    -- the brain more.  Consider that if this test ever turns out to be a perf+    -- problem (which seems unlikely).   = exprOkForSpeculation scrut    | otherwise  -- Scrut has a lifted type@@ -3120,7 +3130,7 @@ simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)   = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]           let vs_with_evals = addEvals scrut' con vs-        ; (env', vs') <- simplLamBndrs env vs_with_evals+        ; (env', vs') <- simplBinders env vs_with_evals                  -- Bind the case-binder to (con args)         ; let inst_tys' = tyConAppArgs (idType case_bndr')@@ -3644,37 +3654,59 @@ mkDupableAlt :: Platform -> OutId              -> JoinFloats -> OutAlt              -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs')-  | exprIsTrivial rhs'   -- See point (2) of Note [Duplicating join points]-  = return (jfloats, Alt con bndrs' rhs')+mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)+  | exprIsTrivial alt_rhs_in   -- See point (2) of Note [Duplicating join points]+  = return (jfloats, Alt con alt_bndrs alt_rhs_in)    | otherwise-  = do  { let rhs_ty'  = exprType rhs'+  = do  { let rhs_ty'  = exprType alt_rhs_in -              final_bndrs'-                | isDeadBinder case_bndr = filter abstract_over bndrs'-                | otherwise              = bndrs' ++ [case_bndr]+              bangs+                | DataAlt c <- con+                = dataConRepStrictness c+                | otherwise = [] -              abstract_over bndr-                  | isTyVar bndr = True -- Abstract over all type variables just in case-                  | otherwise    = not (isDeadBinder bndr)-                        -- The deadness info on the new Ids is preserved by simplBinders-              final_args = varsToCoreExprs final_bndrs'+              abstracted_binders = abstract_binders alt_bndrs bangs++              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]+              abstract_binders [] []+                -- Abstract over the case binder too if it's used.+                | isDeadBinder case_bndr  = []+                | otherwise               = [(case_bndr,MarkedStrict)]+              abstract_binders (alt_bndr:alt_bndrs) marks+                -- Abstract over all type variables just in case+                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks+              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)+                -- The deadness info on the new Ids is preserved by simplBinders+                -- We don't abstract over dead ids here.+                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks+                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks+              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)++              filtered_binders = map fst abstracted_binders+              -- We want to make any binder with an evaldUnfolding strict in the rhs.+              -- See Note [Call-by-value for worker args] (which also applies to join points)+              (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in++              final_args = varsToCoreExprs filtered_binders                            -- Note [Join point abstraction]                  -- We make the lambdas into one-shot-lambdas.  The                 -- join point is sure to be applied at most once, and doing so                 -- prevents the body of the join point being floated out by                 -- the full laziness pass-              really_final_bndrs     = map one_shot final_bndrs'+              final_bndrs     = map one_shot filtered_binders               one_shot v | isId v    = setOneShotLambda v                          | otherwise = v-              join_rhs   = mkLams really_final_bndrs rhs' -        ; join_bndr <- newJoinId final_bndrs' rhs_ty'+              -- No lambda binder has an unfolding, but (currently) case binders can,+              -- so we must zap them here.+              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs +        ; join_bndr <- newJoinId filtered_binders rhs_ty'+         ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = Alt con bndrs' join_call+              alt'      = Alt con alt_bndrs join_call          ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)                  , alt') }
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -17,7 +17,7 @@         zapSubstEnv, setSubstEnv, bumpCaseDepth,         getInScope, setInScopeFromE, setInScopeFromF,         setInScopeSet, modifyInScope, addNewInScopeIds,-        getSimplRules,+        getSimplRules, enterRecGroupRHSs,          -- * Substitution results         SimplSR(..), mkContEx, substId, lookupRecBndr,@@ -36,7 +36,7 @@         doFloatFromRhs, getTopFloatBinds,          -- * LetFloats-        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,+        LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,         addLetFlts,  mapLetFloats,          -- * JoinFloats@@ -47,7 +47,7 @@ import GHC.Prelude  import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Opt.Monad        ( SimplMode(..) )+import GHC.Core.Opt.Monad        ( SimplMode(..), FloatEnable (..) ) import GHC.Core import GHC.Core.Utils import GHC.Core.Multiplicity     ( scaleScaled )@@ -56,6 +56,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Data.OrdList+import GHC.Data.Graph.UnVar import GHC.Types.Id as Id import GHC.Core.Make            ( mkWildValBinder, mkCoreLet ) import GHC.Driver.Session       ( DynFlags )@@ -97,6 +98,10 @@       , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion       , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr +        -- | Fast OutVarSet tracking which recursive RHSs we are analysing.+        -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.+      , seRecIds :: !UnVarSet+      ----------- Dynamic part of the environment -----------      -- Dynamic in the sense of describing the setup where      -- the expression finally ends up@@ -287,6 +292,7 @@              , seTvSubst   = emptyVarEnv              , seCvSubst   = emptyVarEnv              , seIdSubst   = emptyVarEnv+             , seRecIds    = emptyUnVarSet              , seCaseDepth = 0 }         -- The top level "enclosing CC" is "SUBSUMED". @@ -392,6 +398,13 @@ modifyInScope env@(SimplEnv {seInScope = in_scope}) v   = env {seInScope = extendInScopeSet in_scope v} +enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))+                  -> SimplM (r, SimplEnv)+enterRecGroupRHSs env bndrs k = do+  --pprTraceM "enterRecGroupRHSs" (ppr bndrs)+  (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}+  return (r, env''{seRecIds = seRecIds env})+ {- Note [Setting the right in-scope set] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -493,10 +506,14 @@ andFF FltOkSpec  _          = FltOkSpec andFF FltLifted  flt        = flt -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool--- If you change this function look also at FloatIn.noFloatFromRhs-doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs-  =  not (isNilOL fs) && want_to_float && can_float++doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool+-- If you change this function look also at FloatIn.noFloatIntoRhs+doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+  = floatEnabled lvl fe+      && not (isNilOL fs)+      && want_to_float+      && can_float   where      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs                      -- See Note [Float when cheap or expandable]@@ -505,6 +522,12 @@                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec                    FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind +     -- Whether any floating is allowed by flags.+     floatEnabled :: TopLevelFlag -> FloatEnable -> Bool+     floatEnabled _ FloatDisabled = False+     floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl)+     floatEnabled _ FloatEnabled = True+ {- Note [Float when cheap or expandable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -892,31 +915,18 @@ Note [Arity robustness] ~~~~~~~~~~~~~~~~~~~~~~~ We *do* transfer the arity from the in_id of a let binding to the-out_id.  This is important, so that the arity of an Id is visible in-its own RHS.  For example:-        f = \x. ....g (\y. f y)....-We can eta-reduce the arg to g, because f is a value.  But that-needs to be visible.--This interacts with the 'state hack' too:-        f :: Bool -> IO Int-        f = \x. case x of-                  True  -> f y-                  False -> \s -> ...-Can we eta-expand f?  Only if we see that f has arity 1, and then we-take advantage of the 'state hack' on the result of-(f y) :: State# -> (State#, Int) to expand the arity one more.--There is a disadvantage though.  Making the arity visible in the RHS-allows us to eta-reduce-        f = \x -> f x-to-        f = f-which technically is not sound.  We take care of that in point (3) of-Note [Eta reduction makes sense].-Another idea is to ensure that f's arity never decreases; its arity started as-1, and we should never eta-reduce below that.+out_id so that its arity is visible in its RHS. Examples: +  * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)+    Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a+    hard time figuring that out when `f` only has arity 0 in its own RHS.+  * f = \x y. ....(f `seq` blah)....+    We want to drop the seq.+  * f = \x. g (\y. f y)+    You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.+    Unfortunately, it is not sound in general to eta-reduce in f's RHS.+    Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how+    we prevent that.  Note [Robust OccInfo] ~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -48,7 +48,7 @@ import GHC.Core import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) )+import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..), floatEnable ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType )@@ -951,12 +951,14 @@                            , sm_cast_swizzle = True                            , sm_case_case  = True                            , sm_pre_inline = pre_inline_on+                           , sm_float_enable = float_enable                            }   where     rules_on      = gopt Opt_EnableRewriteRules   dflags     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags     pre_inline_on = gopt Opt_SimplPreInlining     dflags     uf_opts       = unfoldingOpts                 dflags+    float_enable  = floatEnable                   dflags  updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode updModeForStableUnfoldings unf_act current_mode@@ -1662,6 +1664,7 @@        ; try_eta dflags bndrs body }   where     mode     = getMode env+    rec_ids  = seRecIds env     in_scope = getInScope env  -- Includes 'bndrs'     mb_rhs   = contIsRhs cont @@ -1678,7 +1681,7 @@     try_eta dflags bndrs body       | -- Try eta reduction         gopt Opt_DoEtaReduction dflags-      , Just etad_lam <- tryEtaReduce bndrs body (eval_sd dflags)+      , Just etad_lam <- tryEtaReduce rec_ids bndrs body (eval_sd dflags)       = do { tick (EtaReduction (head bndrs))            ; return etad_lam }
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -628,41 +628,12 @@ that we have ForceSpecConstr, this NoSpecConstr is probably redundant. (Used only for PArray, TODO: remove?) -Note [SpecConstr and evaluated unfoldings]+Note [SpecConstr and strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-SpecConstr will attach evaldUnfolding unfoldings to function-arguments representing things that should be fully evaluated-by the time we execute the RHS.--This primarily concerns strict fields. To give an example in the-containers package we have a merge function with this specialization:--  "SC:$wmerge01" [2]-      forall (sc_s5lX :: ghc-prim:GHC.Prim.Int#)-              (sc_s5lY :: ghc-prim:GHC.Prim.Int#)-              (sc_s5lZ-                :: IntMap a_s4UX-                Unf=OtherCon [])-              (sc_s5m0-                :: IntMap a_s4UX-                Unf=OtherCon [])-              (sc_s5lW :: ghc-prim:GHC.Prim.Int#)-              (sc_s5lU :: ghc-prim:GHC.Prim.Int#)-              (sc_s5lV :: a_s4UX).-        $wmerge0_s4UK (Data.IntMap.Internal.Tip @a_s4UX sc_s5lU sc_s5lV)-                      (ghc-prim:GHC.Types.I# sc_s5lW)-                      (Data.IntMap.Internal.Bin-                          @a_s4UX sc_s5lX sc_s5lY sc_s5lZ sc_s5m0)-        = $s$wmerge0_s5m2-            sc_s5lX sc_s5lY sc_s5lZ sc_s5m0 sc_s5lW sc_s5lU sc_s5lV]--We give sc_s5lZ and sc_s5m0 a evaluated unfolding since they come out of-strict field fields in the Bin constructor.-This is especially important since tag inference can then use this-information to adjust the calling convention of-`$wmerge0_s4UK` to enforce arguments being passed fully evaluated+tagged.-See Note [Tag Inference], Note [Strict Worker Ids] for more information on-how we can take advantage of this.+We treat strict fields in SpecConstr the same way we do in W/W.+That is we make the specialized function strict in arguments+representing strict fields. See Note [Call-by-value for worker args]+for why we do this.  Note [Specialising on dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -797,9 +768,10 @@       us     <- getUniqueSupplyM       (_, annos) <- getFirstAnnotations deserializeWithData guts       this_mod <- getModule+      -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)       let binds' = reverse $ fst $ initUs us $ do                     -- Note [Top-level recursive groups]-                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)+                    (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos)                                           (mg_binds guts)                         -- binds is identical to (mg_binds guts), except that the                         -- binders on the LHS have been replaced by extendBndr@@ -904,24 +876,38 @@ the function is applied to a data constructor. -} -data ScEnv = SCE { sc_dflags    :: DynFlags,-                   sc_uf_opts   :: !UnfoldingOpts, -- ^ Unfolding options-                   sc_module    :: !Module,-                   sc_size      :: Maybe Int,   -- Size threshold-                                                -- Nothing => no limit+-- | Options for Specializing over constructors in Core.+data SpecConstrOpts = SpecConstrOpts+  { sc_max_args  :: !Int+  -- ^ The threshold at which a worker-wrapper transformation used as part of+  -- this pass will no longer happen, measured in the number of arguments. -                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn-                                                -- Nothing => no limit-                                                -- See Note [Avoiding exponential blowup]+  , sc_debug     :: !Bool+  -- ^ Whether to print debug information -                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.-                                                -- Stops ForceSpecConstr from diverging.+  , sc_uf_opts   :: !UnfoldingOpts+  -- ^ Unfolding options -                   sc_keen     :: Bool,         -- Specialise on arguments that are known-                                                -- constructors, even if they are not-                                                -- scrutinised in the body.  See-                                                -- Note [Making SpecConstr keener]+  , sc_module    :: !Module+  -- ^ The name of the module being processed +  , sc_size      :: !(Maybe Int)+  -- ^ Size threshold: Nothing => no limit++  , sc_count     :: !(Maybe Int)+  -- ^ Max # of specialisations for any one function. Nothing => no limit.+  -- See Note [Avoiding exponential blowup].++  , sc_recursive :: !Int+  -- ^ Max # of specialisations over recursive type. Stops+  -- ForceSpecConstr from diverging.++  , sc_keen      :: !Bool+  -- ^ Specialise on arguments that are known constructors, even if they are+  -- not scrutinised in the body. See Note [Making SpecConstr keener].+  }++data ScEnv = SCE { sc_opts      :: !SpecConstrOpts,                    sc_force     :: Bool,        -- Force specialisation?                                                 -- See Note [Forcing specialisation] @@ -957,15 +943,21 @@    ppr LambdaVal         = text "<Lambda>"  ----------------------initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv-initScEnv dflags this_mod anns-  = SCE { sc_dflags      = dflags,+initScOpts :: DynFlags -> Module -> SpecConstrOpts+initScOpts dflags this_mod = SpecConstrOpts+        { sc_max_args    = maxWorkerArgs dflags,+          sc_debug       = hasPprDebug dflags,           sc_uf_opts     = unfoldingOpts dflags,           sc_module      = this_mod,           sc_size        = specConstrThreshold dflags,           sc_count       = specConstrCount     dflags,           sc_recursive   = specConstrRecursive dflags,-          sc_keen        = gopt Opt_SpecConstrKeen dflags,+          sc_keen        = gopt Opt_SpecConstrKeen dflags+        }++initScEnv :: SpecConstrOpts -> UniqFM Name SpecConstrAnnotation -> ScEnv+initScEnv opts anns+  = SCE { sc_opts        = opts,           sc_force       = False,           sc_subst       = emptySubst,           sc_how_bound   = emptyVarEnv,@@ -1091,9 +1083,12 @@ -- See Note [Avoiding exponential blowup] decreaseSpecCount env n_specs   = env { sc_force = False   -- See Note [Forcing specialisation]-        , sc_count = case sc_count env of+        , sc_opts = (sc_opts env)+            { sc_count = case sc_count $ sc_opts env of                        Nothing -> Nothing-                       Just n  -> Just (n `div` (n_specs + 1)) }+                       Just n  -> Just $! (n `div` (n_specs + 1))+            }+        }         -- The "+1" takes account of the original function;         -- See Note [Avoiding exponential blowup] @@ -1506,9 +1501,9 @@ scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)  scTopBind env body_usage (Rec prs)-  | Just threshold <- sc_size env+  | Just threshold <- sc_size $ sc_opts env   , not force_spec-  , not (all (couldBeSmallEnoughToInline (sc_uf_opts env) threshold) rhss)+  , not (all (couldBeSmallEnoughToInline (sc_uf_opts $ sc_opts env) threshold) rhss)                 -- No specialisation   = -- pprTrace "scTopBind: nospec" (ppr bndrs) $     do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss@@ -1623,6 +1618,7 @@ specRec top_lvl env body_usg rhs_infos   = go 1 seed_calls nullUsage init_spec_infos   where+    opts = sc_opts env     (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]        | isTopLevel top_lvl        , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs@@ -1652,8 +1648,8 @@        -- Limit recursive specialisation       -- See Note [Limit recursive specialisation]-      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop-      , sc_force env || isNothing (sc_count env)+      | n_iter > sc_recursive opts  -- Too many iterations of the 'go' loop+      , sc_force env || isNothing (sc_count opts)            -- If both of these are false, the sc_count            -- threshold will prevent non-termination       , any ((> the_limit) . si_n_specs) spec_infos@@ -1672,7 +1668,7 @@             ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }      -- See Note [Limit recursive specialisation]-    the_limit = case sc_count env of+    the_limit = case sc_count opts of                   Nothing  -> 10    -- Ugh!                   Just max -> max @@ -1791,7 +1787,7 @@ -}  spec_one env fn arg_bndrs body (call_pat, rule_number)-  | CP { cp_qvars = qvars, cp_args = pats } <- call_pat+  | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat   = do  { spec_uniq <- getUniqueM         ; let env1 = extendScSubstList (extendScInScope env qvars)                                        (arg_bndrs `zip` pats)@@ -1834,17 +1830,14 @@                   , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []                       -- needsVoidWorkerArg: usual w/w hack to avoid generating                       -- a spec_rhs of unlifted type and no args.-                      -- Unlike W/W we don't turn functions into strict workers-                      -- immediately here instead letting tidy handle this.-                      -- For this reason we can ignore the cbv marks.-                      -- See Note [Strict Worker Ids]. See Note [Tag Inference].                   , !spec_arity      <- spec_arity1 + 1                   , !spec_join_arity <- fmap (+ 1) spec_join_arity1                   = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)                   | otherwise                   = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1) -              spec_id    = mkLocalId spec_name Many+              spec_id    = asWorkerLikeId $+                           mkLocalId spec_name Many                                      (mkLamTypes spec_lam_args spec_body_ty)                              -- See Note [Transfer strictness]                              `setIdDmdSig`    spec_sig@@ -1852,38 +1845,52 @@                              `setIdArity`     spec_arity                              `asJoinId_maybe` spec_join_arity -                -- Conditionally use result of new worker-wrapper transform-              spec_rhs   = mkLams spec_lam_args spec_body+        -- Conditionally use result of new worker-wrapper transform+              spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)               rule_rhs = mkVarApps (Var spec_id) $                               -- This will give us all the arguments we quantify over                               -- in the rule plus the void argument if present                               -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`                               dropTail (length extra_bndrs) spec_call_args               inline_act = idInlineActivation fn-              this_mod   = sc_module env+              this_mod   = sc_module $ sc_opts env               rule       = mkRule this_mod True {- Auto -} True {- Local -}                                   rule_name inline_act fn_name qvars pats rule_rhs                            -- See Note [Transfer activation] -        -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+        -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))         --                               , text "sc_count:" <+> ppr (sc_count env)         --                               , text "pats:" <+> ppr pats         --                               , text "call_pat:" <+> ppr call_pat         --                               , text "-->" <+> ppr spec_name         --                               , text "bndrs" <+> ppr arg_bndrs         --                               , text "extra_bndrs" <+> ppr extra_bndrs+        --                               , text "cbv_args" <+> ppr cbv_args         --                               , text "spec_lam_args" <+> ppr spec_lam_args         --                               , text "spec_call_args" <+> ppr spec_call_args         --                               , text "rule_rhs" <+> ppr rule_rhs-        --                               , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg+        --                               , text "adds_void_worker_arg" <+> ppr add_void_arg         --                               , text "body" <+> ppr body         --                               , text "spec_rhs" <+> ppr spec_rhs-        --                               , text "how_bound" <+> ppr (sc_how_bound env) ]) $-        --   return ()+        --                               , text "how_bound" <+> ppr (sc_how_bound env) ])         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule                                , os_id = spec_id                                , os_rhs = spec_rhs }) } +-- See Note [SpecConstr and strict fields]+mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr+mkSeqs seqees res_ty rhs =+  foldr addEval rhs seqees+    where+      addEval :: Var -> CoreExpr -> CoreExpr+      addEval arg_id rhs+        -- Argument representing strict field and it's worth passing via cbv+        | shouldStrictifyIdForCbv arg_id+        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])+        | otherwise+        = rhs++ {- Note [SpecConst needs to add void args first] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function@@ -2173,13 +2180,15 @@ -}  data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables-                  , cp_args  :: [CoreExpr] }    -- Arguments+                  , cp_args  :: [CoreExpr]      -- Arguments+                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed      -- See Note [SpecConstr call patterns]  instance Outputable CallPat where-  ppr (CP { cp_qvars = qvars, cp_args = args })+  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })     = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma-                               , text "cp_args =" <+> ppr args ])+                               , text "cp_args =" <+> ppr args+                               , text "cp_strict_args = " <> ppr strict ])  callsToNewPats :: ScEnv -> Id                -> SpecInfo@@ -2205,9 +2214,8 @@                -- Remove ones that have too many worker variables               small_pats = filterOut too_big non_dups-              max_args = maxWorkerArgs (sc_dflags env)               too_big (CP { cp_qvars = vars, cp_args = args })-                = not (isWorkerSmallEnough max_args (valArgCount args) vars)+                = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)                   -- We are about to construct w/w pair in 'spec_one'.                   -- Omit specialisation leading to high arity workers.                   -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils@@ -2244,7 +2252,7 @@     n_pats         = length pats     spec_count'    = n_pats + done_spec_count     n_remaining    = max_specs - done_spec_count-    mb_scc         = sc_count env+    mb_scc         = sc_count $ sc_opts env     Just max_specs = mb_scc      sorted_pats = map fst $@@ -2269,7 +2277,7 @@           n_cons _           = 0      emit_trace result-       | debugIsOn || hasPprDebug (sc_dflags env)+       | debugIsOn || sc_debug (sc_opts env)          -- Suppress this scary message for ordinary users!  #5125        = pprTrace "SpecConstr" msg result        | otherwise@@ -2292,16 +2300,16 @@ callToPats env bndr_occs call@(Call fn args con_env)   = do  { let in_scope = substInScope (sc_subst env) -        ; pairs <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)+        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)                    -- This zip trims the args to be no longer than                    -- the lambdas in the function definition (bndr_occs)            -- Drop boring patterns from the end           -- See Note [SpecConstr call patterns]-        ; let pairs' | isJoinId fn = pairs-                     | otherwise   = dropWhileEnd is_boring pairs-              is_boring (interesting, _) = not interesting-              (interesting_s, pats) = unzip pairs'+        ; let arg_tripples' | isJoinId fn = arg_tripples+                            | otherwise   = dropWhileEnd is_boring arg_tripples+              is_boring (interesting, _,_) = not interesting+              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'               interesting           = or interesting_s          ; let pat_fvs = exprsFreeVarsList pats@@ -2351,7 +2359,7 @@               --         text "pat_fvs:" <+> ppr pat_fvs               --       )               --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>-              return (Just (CP { cp_qvars = qvars', cp_args = pats }))+              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))           else return Nothing }      -- argToPat takes an actual argument, and returns an abstracted@@ -2366,8 +2374,8 @@          -> CoreArg                     -- A call arg (or component thereof)          -> ArgOcc          -> StrictnessMark              -- Tells us if this argument is a strict field of a data constructor-                                        -- See Note [SpecConstr and evaluated unfoldings]-         -> UniqSM (Bool, CoreArg)+                                        -- See Note [SpecConstr and strict fields]+         -> UniqSM (Bool, CoreArg, [Id])  -- Returns (interesting, pat), -- where pat is the pattern derived from the argument@@ -2392,12 +2400,12 @@   -> Expr CoreBndr   -> ArgOcc   -> StrictnessMark-  -> UniqSM (Bool, Expr CoreBndr)+  -> UniqSM (Bool, Expr CoreBndr, [Id]) argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str-  = return (False, arg)+  = return (False, arg, []) -argToPat1 env in_scope val_env (Tick _ arg) arg_occ _arg_str-  = argToPat env in_scope val_env arg arg_occ _arg_str+argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str+  = argToPat env in_scope val_env arg arg_occ arg_str         -- Note [Tick annotations in call patterns]         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes@@ -2421,7 +2429,7 @@  argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str   | not (ignoreType env ty2)-  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ arg_str+  = do  { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str         ; if not interesting then                 wildCardPat ty2 arg_str           else do@@ -2429,7 +2437,7 @@           uniq <- getUniqueM         ; let co_name = mkSysTvName uniq (fsLit "sg")               co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)-        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }+        ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } }   where     Pair ty1 ty2 = coercionKind co @@ -2465,22 +2473,17 @@       --       ppr rest_args $$       --       ppr (map isTypeArg rest_args))        ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str-       ; let args' = map snd prs :: [CoreArg]+       ; let args' = map sndOf3 prs :: [CoreArg]        ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))             ( ppr con_str $$ ppr rest_args $$               ppr (length con_str) $$ ppr (length rest_args)             ) $ return ()-      --  ; assert (length con_str == length rest_args) $-      --    pprTraceM "argToPat"-      --       ( parens (int $ length con_str) <> ppr con_str  $$-      --         ppr rest_args $$-      --         ppr prs)-       ; return (True, mkConApp dc (ty_args ++ args')) }+       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }   where     mb_scrut dc = case arg_occ of                 ScrutOcc bs | Just occs <- lookupUFM bs dc                             -> Just (occs)  -- See Note [Reboxing]-                _other      | sc_force env || sc_keen env+                _other      | sc_force env || sc_keen (sc_opts env)                             -> Just (repeat UnkOcc)                             | otherwise                             -> Nothing@@ -2503,7 +2506,7 @@   --         business of absence analysis, not SpecConstr.)   --    (b) we know what its value is   -- In that case it counts as "interesting"-argToPat1 env in_scope val_env (Var v) arg_occ _arg_str+argToPat1 env in_scope val_env (Var v) arg_occ arg_str   | sc_force env || case arg_occ of { ScrutOcc {} -> True                                     ; UnkOcc      -> False                                     ; NoOcc       -> False } -- (a)@@ -2512,7 +2515,8 @@        -- So sc_keen focused just on f (I# x), where we have freshly-allocated        -- box that we can eliminate in the caller   , not (ignoreType env (varType v))-  = return (True, Var (setStrUnfolding v MarkedStrict))+  -- See Note [SpecConstr and strict fields]+  = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty)   where     is_value         | isLocalId v = v `elemInScopeSet` in_scope@@ -2544,41 +2548,12 @@ argToPat1 _env _in_scope _val_env arg _arg_occ arg_str   = wildCardPat (exprType arg) arg_str --- We want the given id to be passed call-by-value if it's MarkedCbv.--- For some, but not all ids this can be achieved by giving them an OtherCon unfolding.--- Doesn't touch existing value unfoldings.--- See Note [SpecConstr and evaluated unfoldings]-setStrUnfolding :: Id -> StrictnessMark  -> Id--- setStrUnfolding id str = id-setStrUnfolding id str-  -- pprTrace "setStrUnfolding"-  --   (ppr id <+> ppr (isMarkedCbv str) $$-  --    ppr (idType id) $$-  --    text "boxed:" <> ppr (isBoxedType (idType id)) $$-  --    text "unlifted:" <> ppr (isUnliftedType (idType id))-  --    )-  --   False-  -- = undefined-  | not (isId id) || isEvaldUnfolding (idUnfolding id)-  = id-  | isMarkedStrict str-  , not $ isUnliftedType (idType id) -- Pointless to stick an evald unfolding on unlifted types-  = -- trace "setStrUnfolding2" $-    assert (isId id) $-    assert (not $ hasCoreUnfolding $ idUnfolding id) $-    id `setIdUnfolding` evaldUnfolding-  | otherwise-  = -- trace "setStrUnfolding3"-    id- -- | wildCardPats are always boring-wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg)+wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) wildCardPat ty str   = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty-       ; let id' = id `setStrUnfolding` str-       -- See Note [SpecConstr and evaluated unfoldings]        -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))-       ; return (False, varToCoreExpr id') }+       ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }  isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit)@@ -2636,6 +2611,7 @@         (CP { cp_qvars = vs2, cp_args = as2 })   = all2 same as1 as2   where+    -- If the args are the same, their strictness marks will be too so we don't compare those.     same (Var v1) (Var v2)         | v1 `elem` vs1 = v2 `elem` vs2         | v2 `elem` vs2 = False
compiler/GHC/Core/Opt/Specialise.hs view
@@ -16,7 +16,7 @@ import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Driver.Config.Diagnostic-import GHC.Driver.Env+import GHC.Driver.Config.Core.Rules ( initRuleOpts )  import GHC.Tc.Utils.TcType hiding( substTy ) @@ -30,7 +30,8 @@ import GHC.Core import GHC.Core.Rules import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe-                          , mkCast, exprType )+                          , mkCast, exprType+                          , stripTicksTop ) import GHC.Core.FVs import GHC.Core.TyCo.Rep (TyCoBinder (..)) import GHC.Core.Opt.Arity     ( collectBindersPushingCo@@ -65,7 +66,6 @@  import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts-import GHC.Unit.External import GHC.Core.Unfold  {-@@ -736,10 +736,9 @@   = do {     -- Get rules from the external package state              -- We keep doing this in case we "page-fault in"              -- more rules as we go along-       ; hsc_env <- getHscEnv-       ; eps <- liftIO $ hscEPS hsc_env+       ; external_rule_base <- getExternalRuleBase        ; vis_orphs <- getVisibleOrphanMods-       ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn+       ; let rules_for_fn = getRules (RuleEnv [rb, external_rule_base] vis_orphs) fn         ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])        ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })@@ -1116,7 +1115,10 @@ specExpr env expr@(App {})   = do { let (fun_in, args_in) = collectArgs expr        ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in-       ; let (fun_in', args_out') = rewriteClassOps env fun_in args_out+       ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args+                -- Some dicts may have floated out of args_in;+                -- they should be in scope for rewriteClassOps (#21689)+             (fun_in', args_out') = rewriteClassOps env_args fun_in args_out        ; (fun_out', uds_fun) <- specExpr env fun_in'        ; let uds_call = mkCallUDs env fun_out' args_out'        ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }@@ -1490,7 +1492,8 @@      already_covered :: [CoreRule] -> [CoreExpr] -> Bool     already_covered new_rules args      -- Note [Specialisations already covered]-       = isJust (specLookupRule env fn args (new_rules ++ existing_rules))+       = isJust (specLookupRule env_with_dict_bndrs fn args+                                (new_rules ++ existing_rules))          -- NB: we look both in the new_rules (generated by this invocation          --     of specCalls), and in existing_rules (passed in to specCalls) @@ -2273,7 +2276,7 @@ -- We will use the running example from Note [Specialising Calls]: -- --     f :: forall a b c. Int -> Eq a => Show b => c -> Blah---     f @a @b @c i dEqA dShowA x = blah+--     f @a @b @c i dEqA dShowB x = blah -- -- Suppose we decide to specialise it at the following pattern: --@@ -2289,7 +2292,7 @@ -- and the specialisation '$sf' -- --     $sf :: forall c. Int -> c -> Blah---     $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)+--     $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] (\@c i x -> blah) -- -- where dShow1 is a floated binding created by bindAuxiliaryDict. --@@ -2297,7 +2300,7 @@ -- running example. The result of 'specHeader' for this example is as follows: -- --    ( -- Returned arguments---      env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1]+--      env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] --    , [x] -- --      -- RULE helpers@@ -2680,7 +2683,7 @@  mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails mkCallUDs env fun args-  | Var f <- fun+  | (_, Var f) <- stripTicksTop tickishFloatable fun -- See Note [Ticks on applications]   = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $     mkCallUDs' env f args   | otherwise@@ -2732,6 +2735,22 @@      mk_spec_arg _ (Anon VisArg _)       = UnspecArg++{-+Note [Ticks on applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticks such as source location annotations can sometimes make their way+onto applications (see e.g. #21697). So if we see something like++    App (Tick _ f) e++we need to descend below the tick to find what the real function being+applied is.++The resulting RULE also has to be able to match this annotated use+site, so we only look through ticks that RULE matching looks through+(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).+-}  wantCallsFor :: SpecEnv -> Id -> Bool wantCallsFor _env _f = True
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -36,6 +36,7 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Monad import GHC.Utils.Trace+import GHC.Core.DataCon  {- We take Core bindings whose binders have:@@ -535,7 +536,7 @@   -- See Note [Drop absent bindings]   | isAbsDmd (demandInfo fn_info)   , not (isJoinId fn_id)-  , Just filler <- mkAbsentFiller ww_opts fn_id+  , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict   = return [(new_fn_id, filler)]    -- See Note [Don't w/w INLINE things]@@ -788,10 +789,10 @@  mkWWBindPair :: WwOpts -> Id -> IdInfo              -> [Var] -> CoreExpr -> Unique -> Divergence-             -> ([Demand],[CbvMark], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)+             -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)              -> [(Id, CoreExpr)] mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div-             (work_demands, cbv_marks :: [CbvMark], join_arity, wrap_fn, work_fn)+             (work_demands, join_arity, wrap_fn, work_fn)   = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $     [(work_id, work_rhs), (wrap_id, wrap_rhs)]      -- Worker first, because wrapper mentions it@@ -821,7 +822,8 @@       -- worker is join point iff wrapper is join point       -- (see Note [Don't w/w join points for CPR]) -    work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+    work_id  = asWorkerLikeId $+               mkWorkerId work_uniq fn_id (exprType work_rhs)                 `setIdOccInfo` occInfo fn_info                         -- Copy over occurrence info from parent                         -- Notably whether it's a loop breaker@@ -846,10 +848,7 @@                         -- arity is consistent with the demand type goes                         -- through -                `setIdCbvMarks` cbv_marks-                 `asJoinId_maybe` work_join_arity-                -- `setIdThing` (undefined cbv_marks)      work_arity = length work_demands :: Int @@ -1033,7 +1032,7 @@   = assert (not (isJoinId x)) $     do { let x' = localiseId x -- See comment above        ; (useful,_args, wrap_fn, fn_arg)-           <- mkWWstr_one ww_opts x' NotMarkedCbv+           <- mkWWstr_one ww_opts x' NotMarkedStrict        ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ]        ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive                    return res
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -152,7 +152,6 @@  type WwResult   = ([Demand],              -- Demands for worker (value) args-     [CbvMark],             -- Cbv semantics for worker (value) args      JoinArity,             -- Number of worker (type OR value) args      Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id      CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs@@ -222,7 +221,7 @@               zapped_arg_vars = map zap_var arg_vars               (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars               res_ty' = GHC.Core.Subst.substTy subst res_ty-              init_cbv_marks = map (const NotMarkedCbv) cloned_arg_vars+              init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars          ; (useful1, work_args_cbv, wrap_fn_str, fn_args)              <- mkWWstr opts cloned_arg_vars init_cbv_marks@@ -243,11 +242,13 @@               call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args                                   -- See Note [Join points and beta-redexes]               wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work-              worker_body = mkLams work_lam_args . work_fn_cpr . call_rhs-              (worker_args_dmds, work_val_cbvs)= unzip [(idDemandInfo v,cbv) | (v,cbv) <- zipEqual "mkWwBodies" work_call_args work_call_cbv, isId v]+                                  -- See Note [Call-by-value for worker args]+              work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv)+              worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs+              worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v]          ; if ((useful1 && not only_one_void_argument) || useful2)-          then return (Just (worker_args_dmds, work_val_cbvs, length work_call_args,+          then return (Just (worker_args_dmds, length work_call_args,                        wrapper_body, worker_body))           else return Nothing         }@@ -390,12 +391,12 @@ -- -- Why as the first argument? See Note [SpecConst needs to add void args first] -- in SpecConstr.-addVoidWorkerArg :: [Var] -> [CbvMark]+addVoidWorkerArg :: [Var] -> [StrictnessMark]                  -> ([Var],     -- Lambda bound args                      [Var],     -- Args at call site-                     [CbvMark]) -- cbv semantics for the worker args.+                     [StrictnessMark]) -- cbv semantics for the worker args. addVoidWorkerArg work_args cbv_marks-  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedCbv:cbv_marks)+  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)  {- Note [Protecting the last value argument]@@ -617,7 +618,7 @@   -- That is done by 'finaliseArgBoxities'!   = Unbox (DataConPatContext dc tc_args co) ds -  -- See Note [Strict Worker Ids]+  -- See Note [CBV Function Ids]   | do_unlifting   , isStrUsedDmd dmd   , not (isFunTy ty)@@ -788,7 +789,7 @@ We could still try to do C) in the future by having PAP calls which will evaluate the required arguments before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now.-See also Note [Tag Inference] and Note [Strict Worker Ids]+See also Note [Tag Inference] and Note [CBV Function Ids] -}  {-@@ -802,9 +803,9 @@ mkWWstr :: WwOpts         -> [Var]                         -- Wrapper args; have their demand info on them                                          --  *Includes type variables*-        -> [CbvMark]                     -- cbv info for arguments+        -> [StrictnessMark]                     -- cbv info for arguments         -> UniqSM (Bool,                 -- Will this result in a useful worker-                   [(Var,CbvMark)],      -- Worker args/their call-by-value semantics.+                   [(Var,StrictnessMark)],      -- Worker args/their call-by-value semantics.                    CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call                                          -- and without its lambdas                                          -- This fn adds the unboxing@@ -835,24 +836,24 @@ -- See Note [Worker/wrapper for Strictness and Absence] mkWWstr_one :: WwOpts             -> Var-            -> CbvMark-            -> UniqSM (Bool, [(Var,CbvMark)], CoreExpr -> CoreExpr, CoreExpr)-mkWWstr_one opts arg marked_cbv =+            -> StrictnessMark+            -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)+mkWWstr_one opts arg banged =   case wantToUnboxArg True fam_envs arg_ty arg_dmd of     _ | isTyVar arg -> do_nothing      DropAbsent-      | Just absent_filler <- mkAbsentFiller opts arg+      | Just absent_filler <- mkAbsentFiller opts arg banged          -- Absent case.  Dropt the argument from the worker.          -- We can't always handle absence for arbitrary          -- unlifted types, so we need to choose just the cases we can          -- (that's what mkAbsentFiller does)       -> return (goodWorker, [], nop_fn, absent_filler) -    Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc marked_cbv+    Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged      Unlift -> return  ( wwForUnlifting opts-                      , [(setIdUnfolding arg evaldUnfolding, MarkedCbv)]+                      , [(arg, MarkedStrict)]                       , nop_fn                       , varToCoreExpr arg) @@ -863,15 +864,16 @@     arg_ty     = idType arg     arg_dmd    = idDemandInfo arg     -- Type args don't get cbv marks-    arg_cbv    = if isTyVar arg then NotMarkedCbv else marked_cbv+    arg_cbv    = if isTyVar arg then NotMarkedStrict else banged+     do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg)  unbox_one_arg :: WwOpts           -> Var           -> [Demand]           -> DataConPatContext-          -> CbvMark-          -> UniqSM (Bool, [(Var,CbvMark)], CoreExpr -> CoreExpr, CoreExpr)+          -> StrictnessMark+          -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) unbox_one_arg opts arg_var ds           DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args                             , dcpc_co = co }@@ -881,37 +883,32 @@              -- Create new arguments we get when unboxing dc              (ex_tvs', arg_ids) =                dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args-             -- Apply str info to new args.-             arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds+             con_str_marks = dataConRepStrictness dc+             -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders+             -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders]+             arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds              unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var)                                      dc (ex_tvs' ++ arg_ids')-             -- Mark arguments coming out of strict fields as evaluated and give them cbv semantics. See Note [Strict Worker Ids]-             cbv_arg_marks = zipWithEqual "unbox_one_arg" bangToMark (dataConRepStrictness dc) arg_ids'-             unf_args = zipWith setEvald arg_ids' cbv_arg_marks-             cbv_marks = (map (const NotMarkedCbv) ex_tvs') ++ cbv_arg_marks-       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ unf_args) cbv_marks+             -- Mark arguments coming out of strict fields so we can make the worker strict on those+             -- argumnets later. seq them later. See Note [Call-by-value for worker args]+             strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks+       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks        ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co        ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }                           -- Don't pass the arg, rebox instead-    where bangToMark :: StrictnessMark -> Id -> CbvMark-          bangToMark NotMarkedStrict _ = NotMarkedCbv-          bangToMark MarkedStrict v-            | isUnliftedType (idType v) = NotMarkedCbv-            | otherwise                 = MarkedCbv-          setEvald var NotMarkedCbv  = var-          setEvald var MarkedCbv     = setIdUnfolding var evaldUnfolding  -- | Tries to find a suitable absent filler to bind the given absent identifier -- to. See Note [Absent fillers]. -- -- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the -- same type as @id@. Otherwise, no suitable filler could be found.-mkAbsentFiller :: WwOpts -> Id -> Maybe CoreExpr-mkAbsentFiller opts arg+mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr+mkAbsentFiller opts arg str   -- The lifted case: Bind 'absentError' for a nice panic message if we are   -- wrong (like we were in #11126). See (1) in Note [Absent fillers]   | mightBeLiftedType arg_ty-  , not is_strict, not is_evald -- See (2) in Note [Absent fillers]+  , not is_strict+  , not (isMarkedStrict str) -- See (2) in Note [Absent fillers]   = Just (mkAbsentErrorApp arg_ty msg)    -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`@@ -922,7 +919,6 @@   where     arg_ty    = idType arg     is_strict = isStrictDmd (idDemandInfo arg)-    is_evald  = isEvaldUnfolding $ idUnfolding arg      msg = renderWithContext             (defaultSDocContext { sdocSuppressUniques = True })@@ -1095,29 +1091,28 @@    2. We also mustn't put an error-thunk (that fills in for an absent value of      lifted rep) in a strict field, because #16970 establishes the invariant-     that strict fields are always evaluated, by (re-)evaluating what is put in+     that strict fields are always evaluated, by possibly (re-)evaluating what is put in      a strict field. That's the reason why 'zs' binds a rubbish literal instead      of an error-thunk, see #19133.       How do we detect when we are about to put an error-thunk in a strict field?-     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but-     it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.-     So we rather look out for a necessary condition for strict fields:+     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field. So that's+     what we do!++     There are other necessary conditions for strict fields:      Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on      'zs' is absent and /strict/: It will get cardinality 'C_10', the empty-     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees-     we never fill in an error-thunk for an absent strict field.+     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It further+     guarantees e never fill in an error-thunk for an absent strict field.      But that also means we emit a rubbish lit for other args that have      cardinality 'C_10' (say, the arg to a bottoming function) where we could've-     used an error-thunk, but that's a small price to pay for simplicity.--     In #19766, we discovered that even if the binder has eval cardinality-     'C_00', it may end up in a strict field, with no surrounding seq-     whatsoever! That happens if the calling code has already evaluated-     said lambda binder, which will then have an evaluated unfolding-     ('isEvaldUnfolding'). That in turn tells the Simplifier it is free to drop-     the seq. So we better don't fill in an error-thunk for eval'd arguments-     either, just in case it ends up in a strict field!+     used an error-thunk.+     NB from Andreas: But I think using an error thunk there would be dodgy no matter what+     for example if we decide to pass the argument to the bottoming function cbv.+     As we might do if the function in question is a worker.+     See Note [CBV Function Ids] in GHC.CoreToStg.Prep. So I just left the strictness check+     in place on top of threading through the marks from the constructor. It's a *really* cheap+     and easy check to make anyway.    3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.      of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.
compiler/GHC/CoreToStg/Prep.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE BangPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -11,7 +10,9 @@ -}  module GHC.CoreToStg.Prep-   ( corePrepPgm+   ( CorePrepConfig (..)+   , CorePrepPgmConfig (..)+   , corePrepPgm    , corePrepExpr    , mkConvertNumLiteral    )@@ -21,9 +22,7 @@  import GHC.Platform -import GHC.Driver.Session-import GHC.Driver.Env-import GHC.Driver.Ppr+import GHC.Driver.Flags  import GHC.Tc.Utils.Env import GHC.Unit@@ -37,7 +36,7 @@ import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.Opt.Monad ( CoreToDo(..) )-import GHC.Core.Lint    ( endPassIO )+import GHC.Core.Lint    ( EndPassConfig, endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here import GHC.Core.Type@@ -51,6 +50,7 @@ import GHC.Data.OrdList import GHC.Data.FastString import GHC.Data.Pair+import GHC.Data.Graph.UnVar  import GHC.Utils.Error import GHC.Utils.Misc@@ -68,7 +68,7 @@ import GHC.Types.Id.Info import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic-import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )+import GHC.Types.Name   ( Name, NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import GHC.Types.Literal import GHC.Types.Tickish@@ -137,7 +137,7 @@  12. Collect cost centres (including cost centres in unfoldings) if we're in     profiling mode. We have to do this here beucase we won't have unfoldings-    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].+    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].  13. Eliminate case clutter in favour of unsafe coercions.     See Note [Unsafe coercions]@@ -234,17 +234,28 @@ ************************************************************************ -} -corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]+data CorePrepPgmConfig = CorePrepPgmConfig+  { cpPgm_endPassConfig     :: !EndPassConfig+  , cpPgm_generateDebugInfo :: !Bool+  }++corePrepPgm :: Logger+            -> CorePrepConfig+            -> CorePrepPgmConfig+            -> Module -> ModLocation -> CoreProgram -> [TyCon]             -> IO CoreProgram-corePrepPgm hsc_env this_mod mod_loc binds data_tycons =+corePrepPgm logger cp_cfg pgm_cfg+            this_mod mod_loc binds data_tycons =     withTiming logger                (text "CorePrep"<+>brackets (ppr this_mod))                (\a -> a `seqList` ()) $ do     us <- mkSplitUniqSupply 's'-    initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env+    let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg      let-        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons+        implicit_binds = mkDataConWorkers+          (cpPgm_generateDebugInfo pgm_cfg)+          mod_loc data_tycons             -- NB: we must feed mkImplicitBinds through corePrep too             -- so that they are suitably cloned and eta-expanded @@ -253,18 +264,15 @@                       floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds                       return (deFloatTop (floats1 `appendFloats` floats2)) -    endPassIO hsc_env alwaysQualify CorePrep binds_out []+    endPassIO logger (cpPgm_endPassConfig pgm_cfg)+              alwaysQualify CorePrep binds_out []     return binds_out-  where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env -corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr-corePrepExpr hsc_env expr = do-    let logger = hsc_logger hsc_env+corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr+corePrepExpr logger config expr = do     withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do       us <- mkSplitUniqSupply 's'-      initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env+      let initialCorePrepEnv = mkInitialCorePrepEnv config       let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)       putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)       return new_expr@@ -283,10 +291,10 @@                                floatss <- go env' binds                                return (floats `appendFloats` floatss) -mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]+mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind] -- See Note [Data constructor workers] -- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy-mkDataConWorkers dflags mod_loc data_tycons+mkDataConWorkers generate_debug_info mod_loc data_tycons   = [ NonRec id (tick_it (getName data_con) (Var id))                                 -- The ice is thin here, but it works     | tycon <- data_tycons,     -- CorePrep will eta-expand it@@ -297,11 +305,12 @@    -- If we want to generate debug info, we put a source note on the    -- worker. This is useful, especially for heap profiling.    tick_it name-     | not (needSourceNotes dflags)           = id+     | not generate_debug_info               = id      | RealSrcSpan span _ <- nameSrcSpan name = tick span      | Just file <- ml_hs_file mod_loc       = tick (span1 file)      | otherwise                             = tick (span1 "???")-     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))+     where tick span  = Tick $ SourceNote span $+             renderWithContext defaultSDocContext $ ppr name            span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1  {-@@ -595,7 +604,7 @@                      | otherwise                      = addFloat floats new_float -             new_float = mkFloat dmd is_unlifted bndr1 rhs1+             new_float = mkFloat env dmd is_unlifted bndr1 rhs1         ; return (env2, floats1, Nothing) } @@ -609,24 +618,27 @@  cpeBind top_lvl env (Rec pairs)   | not (isJoinId (head bndrs))-  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+  = do { (env, bndrs1) <- cpCloneBndrs env bndrs+       ; let env' = enterRecGroupRHSs env bndrs1        ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')                            bndrs1 rhss         ; let (floats_s, rhss1) = unzip stuff              all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)                                            (concatFloats floats_s)-+       -- use env below, so that we reset cpe_rec_ids        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),                  unitFloat (FloatLet (Rec all_pairs)),                  Nothing) }    | otherwise -- See Note [Join points and floating]-  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+  = do { (env, bndrs1) <- cpCloneBndrs env bndrs+       ; let env' = enterRecGroupRHSs env bndrs1        ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss         ; let bndrs2 = map fst pairs1-       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),+       -- use env below, so that we reset cpe_rec_ids+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),                  emptyFloats,                  Just (Rec pairs1)) }   where@@ -658,7 +670,7 @@                else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $                                -- Note [Silly extra arguments]                     (do { v <- newVar (idType bndr)-                        ; let float = mkFloat topDmd False v rhs2+                        ; let float = mkFloat env topDmd False v rhs2                         ; return ( addFloat floats2 float                                  , cpeEtaExpand arity (Var v)) }) @@ -774,7 +786,7 @@ cpeRhsE env (Coercion co)   = return (emptyFloats, Coercion (cpSubstCo env co)) cpeRhsE env expr@(Lit (LitNumber nt i))-   = case cpe_convertNumLit env nt i of+   = case cp_convertNumLit (cpe_config env) nt i of       Nothing -> return (emptyFloats, expr)       Just e  -> cpeRhsE env e cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)@@ -848,13 +860,7 @@   = do { (floats, scrut') <- cpeBody env scrut        ; (env', bndr2) <- cpCloneBndr env bndr        ; let alts'-                 -- This flag is intended to aid in debugging strictness-                 -- analysis bugs. These are particularly nasty to chase down as-                 -- they may manifest as segmentation faults. When this flag is-                 -- enabled we instead produce an 'error' expression to catch-                 -- the case where a function we think should bottom-                 -- unexpectedly returns.-               | gopt Opt_CatchNonexhaustiveCases (cpe_dynFlags env)+               | cp_catchNonexhaustiveCases $ cpe_config env                , not (altsAreExhaustive alts)                = addDefault alts (Just err)                | otherwise = alts@@ -1003,6 +1009,7 @@ -- May return a CpeRhs because of saturating primops cpeApp top_env expr   = do { let (terminal, args) = collect_args expr+      --  ; pprTraceM "cpeApp" $ (ppr expr)        ; cpe_app top_env terminal args        } @@ -1122,6 +1129,7 @@                  min_arity = case hd of                    Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing                    Nothing -> Nothing+          --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))            ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity            ; mb_saturate hd app floats unsat_ticks depth }         where@@ -1152,7 +1160,7 @@            ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing            ; mb_saturate Nothing app floats unsat_ticks (val_args args) } -    -- Count the number of value arguments.+    -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)     val_args :: [ArgInfo] -> Int     val_args args = go args 0       where@@ -1168,7 +1176,7 @@             CpeApp e                                  -> go infos n'               where                 !n'-                  | isTyCoArg e = n+                  | isTypeArg e = n                   | otherwise   = n+1      -- Saturate if necessary@@ -1208,7 +1216,7 @@         -> Int -- Number of arguments required to satisfy minimal tick scopes.         -> UniqSM (CpeApp, Floats, [CoreTickish])     rebuild_app' _ [] app floats ss rt_ticks !_req_depth-      = assert (null ss) -- make sure we used all the strictness info+      = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info         return (app, floats, rt_ticks)      rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of@@ -1226,9 +1234,12 @@           arg_ty' = cpSubstTy env arg_ty        CpeApp (Coercion co)-        -> rebuild_app' env as (App fun' (Coercion co')) floats ss rt_ticks req_depth+        -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth         where             co' = cpSubstCo env co+            ss'+              | null ss = []+              | otherwise = tail ss        CpeApp arg -> do         let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1508,7 +1519,7 @@        ; if okCpeArg arg2          then do { v <- newVar arg_ty                  ; let arg3      = cpeEtaExpand (exprArity arg2) arg2-                       arg_float = mkFloat dmd is_unlifted v arg3+                       arg_float = mkFloat env dmd is_unlifted v arg3                  ; return (addFloat floats2 arg_float, varToCoreExpr v) }          else return (floats2, arg2)        }@@ -1551,14 +1562,23 @@   | hasNoBinding fn        -- There's no binding   = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr -  | mark_arity > 0 -- A strict worker. See Note [Strict Worker Ids]+  | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids]   , not applied_marks   = assertPpr       ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]       ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$           text "marks:" <+> ppr (idCbvMarks_maybe fn) $$-          text "join_arity" <+> ppr (idJoinArity fn)+          text "join_arity" <+> ppr (isJoinId_maybe fn) $$+          text "fn_arity" <+> ppr fn_arity        ) $+    -- pprTrace "maybeSat"+    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$+    --       text "fn_arity" <+> ppr fn_arity $$+    --       text "excess_arity" <+> ppr excess_arity $$+    --       text "mark_arity" <+> ppr mark_arity+    --    ) $     return sat_expr    | otherwise@@ -1654,6 +1674,66 @@ long as the callee might evaluate it. And if it is evaluated on most code paths anyway, we get to turn the unknown eval in the callee into a known call at the call site.++However, we must be very careful not to speculate recursive calls!+Doing so might well change termination behavior.++That comes up in practice for DFuns, which are considered ok-for-spec,+because they always immediately return a constructor.+Not so if you speculate the recursive call, as #20836 shows:++  class Foo m => Foo m where+    runFoo :: m a -> m a+  newtype Trans m a = Trans { runTrans :: m a }+  instance Monad m => Foo (Trans m) where+    runFoo = id++(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The+example in #20836 is more compelling, but boils down to the same thing.)+This program compiles to the following DFun for the `Trans` instance:++  Rec {+  $fFooTrans+    = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)+  end Rec }++Note that the DFun immediately terminates and produces a dictionary, just+like DFuns ought to, but it calls itself recursively to produce the `Foo m`+dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so+that we can speculate its calls, and hence use call-by-value, we get:++  $fFooTrans+    = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->+                      C:Foo sc (\ @a -> id)++and that's an infinite loop!+Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the+*body* of the letrec, it's absolutely fine to use call-by-value on+`foo ($fFooTrans d)`.++Our solution is this: we track in cpe_rec_ids the set of enclosing+recursively-bound Ids, the RHSs of which we are currently transforming and then+in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',+basically) we'll say that any binder in this set is not ok-for-spec.++Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we+prep up `rhs1`, we have to include not only `f1`, but all binders of the group+`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive+DFuns.++NB: If at some point we decide to have a termination analysis for general+functions (#8655, !1866), we need to take similar precautions for (guarded)+recursive functions:++  repeat x = x : repeat x++Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`+is a cheap call that we are willing to speculate, but *not* in repeat's RHS.+Fortunately, pce_rec_ids already has all the information we need in that case.++The problem is very similar to Note [Eta reduction in recursive RHSs].+Here as well as there it is *unsound* to change the termination properties+of the very function whose termination properties we are exploiting. -}  data FloatingBind@@ -1700,8 +1780,8 @@                         -- ok-to-speculate unlifted bindings    | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings -mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind-mkFloat dmd is_unlifted bndr rhs+mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind+mkFloat env dmd is_unlifted bndr rhs   | is_strict || ok_for_spec -- See Note [Speculative evaluation]   , not is_hnf  = FloatCase rhs bndr DEFAULT [] ok_for_spec     -- Don't make a case for a HNF binding, even if it's strict@@ -1728,7 +1808,8 @@   where     is_hnf      = exprIsHNF rhs     is_strict   = isStrUsedDmd dmd-    ok_for_spec = exprOkForSpeculation rhs+    ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs+    is_rec_call = (`elemUnVarSet` cpe_rec_ids env)  emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL@@ -1906,8 +1987,25 @@  -} +data CorePrepConfig = CorePrepConfig+  { cp_catchNonexhaustiveCases :: !Bool+  -- ^ Whether to generate a default alternative with ``error`` in these+  -- cases. This is helpful when debugging demand analysis or type+  -- checker bugs which can sometimes manifest as segmentation faults.++  , cp_convertNumLit           :: !(LitNumType -> Integer -> Maybe CoreExpr)+  -- ^ Convert some numeric literals (Integer, Natural) into their final+  -- Core form.+  }+ data CorePrepEnv-  = CPE { cpe_dynFlags        :: DynFlags+  = CPE { cpe_config          :: !CorePrepConfig+        -- ^ This flag is intended to aid in debugging strictness+        -- analysis bugs. These are particularly nasty to chase down as+        -- they may manifest as segmentation faults. When this flag is+        -- enabled we instead produce an 'error' expression to catch+        -- the case where a function we think should bottom+        -- unexpectedly returns.         , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids         -- ^ This environment is used for three operations:         --@@ -1923,19 +2021,15 @@          , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv] -        , cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr-        -- ^ Convert some numeric literals (Integer, Natural) into their-        -- final Core form+        , cpe_rec_ids         :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]     } -mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv-mkInitialCorePrepEnv hsc_env = do-   convertNumLit <- mkConvertNumLiteral hsc_env-   return $ CPE-      { cpe_dynFlags      = hsc_dflags hsc_env+mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv+mkInitialCorePrepEnv cfg = CPE+      { cpe_config        = cfg       , cpe_env           = emptyVarEnv       , cpe_tyco_env      = Nothing-      , cpe_convertNumLit = convertNumLit+      , cpe_rec_ids       = emptyUnVarSet       }  extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv@@ -1957,6 +2051,10 @@         Nothing  -> Var id         Just exp -> exp +enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv+enterRecGroupRHSs env grp+  = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }+ ------------------------------------------------------------------------------ --           CpeTyCoEnv -- ---------------------------------------------------------------------------@@ -2089,7 +2187,7 @@        -- Drop (now-useless) rules/unfoldings        -- See Note [Drop unfoldings and rules]        -- and Note [Preserve evaluatedness] in GHC.Core.Tidy-       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)+       ; let unfolding' = trimUnfolding (realIdUnfolding bndr)                           -- Simplifier will set the Id's unfolding               bndr'' = bndr' `setIdUnfolding`      unfolding'@@ -2206,13 +2304,12 @@  -- | Create a function that converts Bignum literals into their final CoreExpr mkConvertNumLiteral-   :: HscEnv+   :: Platform+   -> HomeUnit+   -> (Name -> IO TyThing)    -> IO (LitNumType -> Integer -> Maybe CoreExpr)-mkConvertNumLiteral hsc_env = do+mkConvertNumLiteral platform home_unit lookup_global = do    let-      dflags   = hsc_dflags hsc_env-      platform = targetPlatform dflags-      home_unit = hsc_home_unit hsc_env       guardBignum act          | isHomeUnitInstanceOf home_unit primUnitId          = return $ panic "Bignum literals are not supported in ghc-prim"@@ -2220,7 +2317,7 @@          = return $ panic "Bignum literals are not supported in ghc-bignum"          | otherwise = act -      lookupBignumId n      = guardBignum (tyThingId <$> lookupGlobal hsc_env n)+      lookupBignumId n      = guardBignum (tyThingId <$> lookup_global n)     -- The lookup is done here but the failure (panic) is reported lazily when we    -- try to access the `bigNatFromWordList` function.@@ -2237,8 +2334,6 @@        convertBignatPrim i =          let-            target    = targetPlatform dflags-             -- ByteArray# literals aren't supported (yet). Were they supported,             -- we would use them directly. We would need to handle             -- wordSize/endianness conversion between host and target@@ -2254,11 +2349,10 @@                   f x = let low  = x .&. mask                             high = x `shiftR` bits                         in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)-                  bits = platformWordSizeInBits target+                  bits = platformWordSizeInBits platform                   mask = 2 ^ bits - 1           in mkApps (Var bignatFromWordListId) [words]      return convertNumLit-
− compiler/GHC/Data/Graph/UnVar.hs 
@@ -1,181 +0,0 @@-{---Copyright (c) 2014 Joachim Breitner--A data structure for undirected graphs of variables-(or in plain terms: Sets of unordered pairs of numbers)---This is very specifically tailored for the use in CallArity. In particular it-stores the graph as a union of complete and complete bipartite graph, which-would be very expensive to store as sets of edges or as adjanceny lists.--It does not normalize the graphs. This means that g `unionUnVarGraph` g is-equal to g, but twice as expensive and large.---}-module GHC.Data.Graph.UnVar-    ( UnVarSet-    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets-    , extendUnVarSet, delUnVarSet-    , elemUnVarSet, isEmptyUnVarSet-    , UnVarGraph-    , emptyUnVarGraph-    , unionUnVarGraph, unionUnVarGraphs-    , completeGraph, completeBipartiteGraph-    , neighbors-    , hasLoopAt-    , delNode-    ) where--import GHC.Prelude--import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Unique.FM-import GHC.Utils.Outputable-import GHC.Types.Unique--import qualified Data.IntSet as S---- We need a type for sets of variables (UnVarSet).--- We do not use VarSet, because for that we need to have the actual variable--- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.--- Therefore, use a IntSet directly (which is likely also a bit more efficient).---- Set of uniques, i.e. for adjancet nodes-newtype UnVarSet = UnVarSet (S.IntSet)-    deriving Eq--k :: Var -> Int-k v = getKey (getUnique v)--emptyUnVarSet :: UnVarSet-emptyUnVarSet = UnVarSet S.empty--elemUnVarSet :: Var -> UnVarSet -> Bool-elemUnVarSet v (UnVarSet s) = k v `S.member` s---isEmptyUnVarSet :: UnVarSet -> Bool-isEmptyUnVarSet (UnVarSet s) = S.null s--delUnVarSet :: UnVarSet -> Var -> UnVarSet-delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s--minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet-minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'--sizeUnVarSet :: UnVarSet -> Int-sizeUnVarSet (UnVarSet s) = S.size s--mkUnVarSet :: [Var] -> UnVarSet-mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs--varEnvDom :: VarEnv a -> UnVarSet-varEnvDom ae = UnVarSet $ ufmToSet_Directly ae--extendUnVarSet :: Var -> UnVarSet -> UnVarSet-extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s--unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet-unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)--unionUnVarSets :: [UnVarSet] -> UnVarSet-unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet--instance Outputable UnVarSet where-    ppr (UnVarSet s) = braces $-        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]--data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph-                | CG    !UnVarSet           -- ^ complete graph-                | Union UnVarGraph UnVarGraph-                | Del   !UnVarSet UnVarGraph--emptyUnVarGraph :: UnVarGraph-emptyUnVarGraph = CG emptyUnVarSet--unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph-{--Premature optimisation, it seems.-unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])-    | s1 == s3 && s2 == s4-    = pprTrace "unionUnVarGraph fired" empty $-      completeGraph (s1 `unionUnVarSet` s2)-unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])-    | s2 == s3 && s1 == s4-    = pprTrace "unionUnVarGraph fired2" empty $-      completeGraph (s1 `unionUnVarSet` s2)--}-unionUnVarGraph a b-  | is_null a = b-  | is_null b = a-  | otherwise = Union a b--unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph-unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph---- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }-completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph-completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2--completeGraph :: UnVarSet -> UnVarGraph-completeGraph s = prune $ CG s---- (v' ∈ neighbors G v) <=> v--v' ∈ G-neighbors :: UnVarGraph -> Var -> UnVarSet-neighbors = go-  where-    go (Del d g) v-      | v `elemUnVarSet` d = emptyUnVarSet-      | otherwise          = go g v `minusUnVarSet` d-    go (Union g1 g2) v     = go g1 v `unionUnVarSet` go g2 v-    go (CG s) v            = if v `elemUnVarSet` s then s else emptyUnVarSet-    go (CBPG s1 s2) v      = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`-                             (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)---- hasLoopAt G v <=> v--v ∈ G-hasLoopAt :: UnVarGraph -> Var -> Bool-hasLoopAt = go-  where-    go (Del d g) v-      | v `elemUnVarSet` d  = False-      | otherwise           = go g v-    go (Union g1 g2) v      = go g1 v || go g2 v-    go (CG s) v             = v `elemUnVarSet` s-    go (CBPG s1 s2) v       = v `elemUnVarSet` s1 && v `elemUnVarSet` s2--delNode :: UnVarGraph -> Var -> UnVarGraph-delNode (Del d g) v = Del (extendUnVarSet v d) g-delNode g         v-  | is_null g       = emptyUnVarGraph-  | otherwise       = Del (mkUnVarSet [v]) g---- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`-prune :: UnVarGraph -> UnVarGraph-prune = go emptyUnVarSet-  where-    go :: UnVarSet -> UnVarGraph -> UnVarGraph-    go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g-    go dels (Union g1 g2)-      | is_null g1' = g2'-      | is_null g2' = g1'-      | otherwise   = Union g1' g2'-      where-        g1' = go dels g1-        g2' = go dels g2-    go dels (CG s)        = CG (s `minusUnVarSet` dels)-    go dels (CBPG s1 s2)  = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels)---- | Shallow empty check.-is_null :: UnVarGraph -> Bool-is_null (CBPG s1 s2)  = isEmptyUnVarSet s1 || isEmptyUnVarSet s2-is_null (CG   s)      = isEmptyUnVarSet s-is_null _             = False--instance Outputable UnVarGraph where-    ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)-    ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)-    ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)-    ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)
+ compiler/GHC/Driver/Config/Core/Rules.hs view
@@ -0,0 +1,23 @@+module GHC.Driver.Config.Core.Rules+  ( initRuleOpts+  ) where++import GHC.Prelude++import GHC.Driver.Flags+import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ )++import GHC.Core.Rules.Config++import GHC.Unit.Types     ( primUnitId, bignumUnitId )++-- | Initialize RuleOpts from DynFlags+initRuleOpts :: DynFlags -> RuleOpts+initRuleOpts dflags = RuleOpts+  { roPlatform                = targetPlatform dflags+  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags+  , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+    -- disable bignum rules in ghc-prim and ghc-bignum itself+  , roBignumRules             = homeUnitId_ dflags /= primUnitId+                                && homeUnitId_ dflags /= bignumUnitId+  }
+ compiler/GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -0,0 +1,32 @@+module GHC.Driver.Config.CoreToStg.Prep+  ( initCorePrepConfig+  , initCorePrepPgmConfig+  ) where++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Config.Core.Lint+import GHC.Runtime.Context ( InteractiveContext )+import GHC.Tc.Utils.Env++import GHC.CoreToStg.Prep++initCorePrepConfig :: HscEnv -> IO CorePrepConfig+initCorePrepConfig hsc_env = do+   convertNumLit <- do+     let platform = targetPlatform $ hsc_dflags hsc_env+         home_unit = hsc_home_unit hsc_env+         lookup_global = lookupGlobal hsc_env+     mkConvertNumLiteral platform home_unit lookup_global+   return $ CorePrepConfig+      { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env+      , cp_convertNumLit = convertNumLit+      }++initCorePrepPgmConfig :: InteractiveContext -> DynFlags -> CorePrepPgmConfig+initCorePrepPgmConfig ic dflags = CorePrepPgmConfig+  { cpPgm_endPassConfig     = initEndPassConfig ic dflags+  , cpPgm_generateDebugInfo = needSourceNotes dflags+  }
+ compiler/GHC/Driver/Config/HsToCore/Ticks.hs view
@@ -0,0 +1,28 @@+module GHC.Driver.Config.HsToCore.Ticks+  ( initTicksConfig+  )+where++import GHC.Prelude++import Data.Maybe (catMaybes)++import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.HsToCore.Ticks++initTicksConfig :: DynFlags -> TicksConfig+initTicksConfig dflags = TicksConfig+  { ticks_passes       = coveragePasses dflags+  , ticks_profAuto     = profAuto dflags+  , ticks_countEntries = gopt Opt_ProfCountEntries dflags+  }++coveragePasses :: DynFlags -> [TickishType]+coveragePasses dflags = catMaybes+  [ ifA Breakpoints $ backendWantsBreakpointTicks $ backend dflags+  , ifA HpcTicks $ gopt Opt_Hpc dflags+  , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto+  , ifA SourceNotes $ needSourceNotes dflags+  ]+  where ifA x cond = if cond then Just x else Nothing
compiler/GHC/Driver/Main.hs view
@@ -112,6 +112,8 @@ import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO, lintInteractiveExpr )+import GHC.Driver.Config.CoreToStg.Prep import GHC.Driver.Config.Logger   (initLogFlags) import GHC.Driver.Config.Parser   (initParserOpts) import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)@@ -155,7 +157,6 @@ import GHC.Core import GHC.Core.Tidy           ( tidyExpr ) import GHC.Core.Type           ( Type, Kind )-import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO ) import GHC.Core.Multiplicity import GHC.Core.Utils          ( exprType ) import GHC.Core.ConLike@@ -1689,9 +1690,13 @@         -------------------         -- PREPARE FOR CODE GENERATION         -- Do saturation and convert to A-normal form-        (prepd_binds) <- {-# SCC "CorePrep" #-}-                       corePrepPgm hsc_env this_mod location-                                   core_binds data_tycons+        (prepd_binds) <- {-# SCC "CorePrep" #-} do+          cp_cfg <- initCorePrepConfig hsc_env+          corePrepPgm+            (hsc_logger hsc_env)+            cp_cfg+            (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))+            this_mod location core_binds data_tycons          -----------------  Convert to STG ------------------         (stg_binds, denv, (caf_ccs, caf_cc_stacks))@@ -1768,8 +1773,13 @@     -------------------     -- PREPARE FOR CODE GENERATION     -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-}-                   corePrepPgm hsc_env this_mod location core_binds data_tycons+    prepd_binds <- {-# SCC "CorePrep" #-} do+      cp_cfg <- initCorePrepConfig hsc_env+      corePrepPgm+        (hsc_logger hsc_env)+        cp_cfg+        (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))+        this_mod location core_binds data_tycons      (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)       <- {-# SCC "CoreToStg" #-}@@ -2110,8 +2120,13 @@      {- Prepare For Code Generation -}     -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-}-      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons+    prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ do+      cp_cfg <- initCorePrepConfig hsc_env+      corePrepPgm+        (hsc_logger hsc_env)+        cp_cfg+        (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))+        this_mod iNTERACTIVELoc core_binds data_tycons      (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)         <- {-# SCC "CoreToStg" #-}@@ -2281,7 +2296,7 @@   let all_tidy_binds = cg_binds cgguts   let print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts) -  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules+  endPassHscEnvIO 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@@ -2327,7 +2342,10 @@          ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr             {- Prepare for codegen -}-         ; prepd_expr <- corePrepExpr hsc_env tidy_expr+         ; cp_cfg <- initCorePrepConfig hsc_env+         ; prepd_expr <- corePrepExpr+            (hsc_logger hsc_env) cp_cfg+            tidy_expr             {- Lint if necessary -}          ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -573,7 +573,7 @@        -- escape the characters \, ", and ', but don't try to escape        -- Unicode or anything else (so we don't use Util.charToC        -- here).  If we get this wrong, then in-       -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in+       -- GHC.HsToCore.Ticks.isGoodTickSrcSpan where we check that the filename in        -- a SrcLoc is the same as the source filenaame, the two will        -- look bogusly different. See test:        -- libraries/hpc/tests/function/subdir/tough2.hs@@ -1362,7 +1362,7 @@    4) -fhpc   At some point during compilation with -fhpc, in the function-  `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a+  `GHC.HsToCore.Ticks.isGoodTickSrcSpan`, we compare the filename that a   `SrcSpan` refers to with the name of the file we are currently compiling.   For some reason I don't yet understand, they can sometimes legitimally be   different, and then hpc ignores that SrcSpan.
compiler/GHC/Hs/Syn/Type.hs view
@@ -48,7 +48,7 @@ hsPatType (BangPat _ pat)               = hsLPatType pat hsPatType (LazyPat _ pat)               = hsLPatType pat hsPatType (LitPat _ lit)                = hsLitType lit-hsPatType (AsPat _ var _)               = idType (unLoc var)+hsPatType (AsPat _ var _ _)             = idType (unLoc var) hsPatType (ViewPat ty _ _)              = ty hsPatType (ListPat ty _)                = mkListTy ty hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys@@ -101,7 +101,7 @@ hsExprType (HsLam     _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f-hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x+hsExprType (HsAppType x f _ _) = piResultTy (lhsExprType f) x hsExprType (OpApp v _ _ _) = dataConCantHappen v hsExprType (NegApp _ _ se) = syntaxExprType se hsExprType (HsPar _ _ e _) = lhsExprType e@@ -125,13 +125,14 @@   Nothing -> asi_ty   where     asi_ty = arithSeqInfoType asi-hsExprType (HsTypedBracket   (HsBracketTc _ ty _wrap _pending) _) = ty-hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty-hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"-                                      (ppr e)+hsExprType (HsTypedBracket   (HsBracketTc { hsb_ty = ty }) _) = ty+hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty+hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice"+                                          (ppr e)                                       -- Typed splices should have been eliminated during zonking, but we                                       -- can't use `dataConCantHappen` since they are still present before                                       -- than in the typechecked AST.+hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e
compiler/GHC/HsToCore.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -20,6 +20,8 @@  import GHC.Driver.Session import GHC.Driver.Config+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )+import GHC.Driver.Config.HsToCore.Ticks import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend@@ -33,6 +35,8 @@ import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl+import GHC.HsToCore.Ticks+import GHC.HsToCore.Breakpoints import GHC.HsToCore.Coverage import GHC.HsToCore.Docs @@ -52,7 +56,6 @@ import GHC.Core.Make import GHC.Core.Rules import GHC.Core.Opt.Monad ( CoreToDo(..) )-import GHC.Core.Lint     ( endPassIO ) import GHC.Core.Ppr  import GHC.Builtin.Names@@ -62,6 +65,7 @@ import GHC.Data.FastString import GHC.Data.Maybe    ( expectJust ) import GHC.Data.OrdList+import GHC.Data.SizedSeq ( sizeSS )  import GHC.Utils.Error import GHC.Utils.Outputable@@ -92,6 +96,7 @@  import Data.List (partition) import Data.IORef+import Data.Traversable (for)  {- ************************************************************************@@ -147,19 +152,33 @@      do { -- Desugar the program         ; let export_set = availsToNameSet exports               bcknd      = backend dflags-              hpcInfo    = emptyHpcInfo other_hpc_info -        ; (binds_cvr, ds_hpc_info, modBreaks)+        ; (binds_cvr, m_tickInfo)                          <- if not (isHsBootOrSig hsc_src)                               then addTicksToBinds-                                       (CoverageConfig-                                        { coverageConfig_logger = hsc_logger hsc_env-                                        , coverageConfig_dynFlags = hsc_dflags hsc_env-                                        , coverageConfig_mInterp = hsc_interp hsc_env-                                        })+                                       (hsc_logger hsc_env)+                                       (initTicksConfig (hsc_dflags hsc_env))                                        mod mod_loc                                        export_set (typeEnvTyCons type_env) binds-                              else return (binds, hpcInfo, Nothing)+                              else return (binds, Nothing)+        ; modBreaks <- for+           [ (i, s)+           | i <- hsc_interp hsc_env+           , (_, s) <- m_tickInfo+           , backendWantsBreakpointTicks (backend dflags)+           ]+           $ \(interp, specs) -> mkModBreaks interp mod specs++        ; ds_hpc_info <- case m_tickInfo of+            Just (orig_file2, ticks)+              | gopt Opt_Hpc $ hsc_dflags hsc_env+              -> do+              hashNo <- if gopt Opt_Hpc $ hsc_dflags hsc_env+                then writeMixEntries (hpcDir dflags) mod ticks orig_file2+                else return 0 -- dummy hash when none are written+              pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo+            _ -> pure $ emptyHpcInfo other_hpc_info+         ; (msgs, mb_res) <- initDs hsc_env tcg_env $                        do { ds_ev_binds <- dsEvBinds ev_binds                           ; core_prs <- dsTopLHsBinds binds_cvr@@ -192,7 +211,7 @@         -- You might think it doesn't matter, but the simplifier brings all top-level         -- things into the in-scope set before simplifying; so we get no unfolding for F#! -        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps+        ; endPassHscEnvIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps         ; let simpl_opts = initSimpleOpts dflags         ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)                 = simpleOptPgm simpl_opts mod final_pgm rules_for_imps@@ -201,7 +220,7 @@         ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"             FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) -        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps+        ; endPassHscEnvIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps          ; let used_names = mkUsedNames tcg_env               pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
+ compiler/GHC/HsToCore/Breakpoints.hs view
@@ -0,0 +1,54 @@+module GHC.HsToCore.Breakpoints+  ( mkModBreaks+  ) where++import GHC.Prelude++import qualified GHC.Runtime.Interpreter as GHCi+import GHC.Runtime.Interpreter.Types+import GHCi.RemoteTypes+import GHC.ByteCode.Types+import GHC.Stack.CCS+import GHC.Unit++import GHC.HsToCore.Ticks (Tick (..))++import GHC.Data.SizedSeq+import GHC.Utils.Outputable as Outputable++import Data.List (intersperse)+import Data.Array++mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks+mkModBreaks interp mod extendedMixEntries+  = do+    let count = fromIntegral $ sizeSS extendedMixEntries+        entries = ssElts extendedMixEntries++    breakArray <- GHCi.newBreakArray interp count+    ccs <- mkCCSArray interp mod count entries+    let+           locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]+           varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]+           declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]+    return $ emptyModBreaks+                       { modBreaks_flags = breakArray+                       , modBreaks_locs  = locsTicks+                       , modBreaks_vars  = varsTicks+                       , modBreaks_decls = declsTicks+                       , modBreaks_ccs   = ccs+                       }++mkCCSArray+  :: Interp -> Module -> Int -> [Tick]+  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))+mkCCSArray interp modul count entries+  | GHCi.interpreterProfiled interp = do+      let module_str = moduleNameString (moduleName modul)+      costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)+      return (listArray (0,count-1) costcentres)+  | otherwise = return (listArray (0,-1) [])+ where+    mk_one t = (name, src)+      where name = concat $ intersperse "." $ tick_path t+            src = renderWithContext defaultSDocContext $ ppr $ tick_loc t
compiler/GHC/HsToCore/Coverage.hs view
@@ -1,1345 +1,116 @@-{-# LANGUAGE DeriveFunctor            #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies             #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(c) Galois, 2006-(c) University of Glasgow, 2007--}--module GHC.HsToCore.Coverage-  ( CoverageConfig (..)-  , addTicksToBinds-  , hpcInitCode-  ) where--import GHC.Prelude as Prelude--import GHC.Driver.Session-import GHC.Driver.Backend--import qualified GHC.Runtime.Interpreter as GHCi-import GHCi.RemoteTypes-import GHC.ByteCode.Types-import GHC.Stack.CCS-import GHC.Hs-import GHC.Unit-import GHC.Cmm.CLabel--import GHC.Core.Type-import GHC.Core.TyCon--import GHC.Data.Maybe-import GHC.Data.FastString-import GHC.Data.Bag--import GHC.Platform--import GHC.Runtime.Interpreter.Types--import GHC.Utils.Misc-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Utils.Monad-import GHC.Utils.Logger--import GHC.Types.SrcLoc-import GHC.Types.Basic-import GHC.Types.Id-import GHC.Types.Var.Set-import GHC.Types.Name.Set hiding (FreeVars)-import GHC.Types.Name-import GHC.Types.HpcInfo-import GHC.Types.CostCentre-import GHC.Types.CostCentre.State-import GHC.Types.ForeignStubs-import GHC.Types.Tickish--import Control.Monad-import Data.List (isSuffixOf, intersperse)-import Data.Array-import Data.Time-import System.Directory--import Trace.Hpc.Mix-import Trace.Hpc.Util--import qualified Data.ByteString as BS-import Data.Set (Set)-import qualified Data.Set as Set--{--************************************************************************-*                                                                      *-*              The main function: addTicksToBinds-*                                                                      *-************************************************************************--}--data CoverageConfig = CoverageConfig-  { coverageConfig_logger   :: Logger--  -- FIXME: replace this with the specific fields of DynFlags we care about.-  , coverageConfig_dynFlags :: DynFlags--  , coverageConfig_mInterp  :: Maybe Interp-  }--addTicksToBinds-        :: CoverageConfig-        -> Module-        -> ModLocation          -- ... off the current module-        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,-                                -- isExportedId doesn't work yet (the desugarer-                                -- hasn't set it), so we have to work from this set.-        -> [TyCon]              -- Type constructor in this module-        -> LHsBinds GhcTc-        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)--addTicksToBinds (CoverageConfig-                 { coverageConfig_logger = logger-                 , coverageConfig_dynFlags = dflags-                 , coverageConfig_mInterp = m_interp-                 })-                mod mod_loc exports tyCons binds-  | let passes = coveragePasses dflags-  , not (null passes)-  , Just orig_file <- ml_hs_file mod_loc = do--     let  orig_file2 = guessSourceFile binds orig_file--          tickPass tickish (binds,st) =-            let env = TTE-                      { fileName     = mkFastString orig_file2-                      , declPath     = []-                      , tte_countEntries = gopt Opt_ProfCountEntries dflags-                      , exports      = exports-                      , inlines      = emptyVarSet-                      , inScope      = emptyVarSet-                      , blackList    = Set.fromList $-                                       mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of-                                                             RealSrcSpan l _ -> Just l-                                                             UnhelpfulSpan _ -> Nothing)-                                                tyCons-                      , density      = mkDensity tickish dflags-                      , this_mod     = mod-                      , tickishType  = tickish-                      }-                (binds',_,st') = unTM (addTickLHsBinds binds) env st-            in (binds', st')--          initState = TT { tickBoxCount = 0-                         , mixEntries   = []-                         , ccIndices    = newCostCentreState-                         }--          (binds1,st) = foldr tickPass (binds, initState) passes--     let tickCount = tickBoxCount st-         entries = reverse $ mixEntries st-     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2-     modBreaks <- mkModBreaks m_interp dflags mod tickCount entries--     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell-       (pprLHsBinds binds1)--     return (binds1, HpcInfo tickCount hashNo, modBreaks)--  | otherwise = return (binds, emptyHpcInfo False, Nothing)--guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath-guessSourceFile binds orig_file =-     -- Try look for a file generated from a .hsc file to a-     -- .hs file, by peeking ahead.-     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->-                               srcSpanFileName_maybe (locA pos) : rest) [] binds-     in-     case top_pos of-        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name-                      -> unpackFS file_name-        _ -> orig_file---mkModBreaks :: Maybe Interp -> DynFlags -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)-mkModBreaks m_interp dflags mod count entries-  | Just interp <- m_interp-  , breakpointsEnabled dflags = do-    breakArray <- GHCi.newBreakArray interp (length entries)-    ccs <- mkCCSArray interp mod count entries-    let-           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]-           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]-           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]-    return $ Just $ emptyModBreaks-                       { modBreaks_flags = breakArray-                       , modBreaks_locs  = locsTicks-                       , modBreaks_vars  = varsTicks-                       , modBreaks_decls = declsTicks-                       , modBreaks_ccs   = ccs-                       }-  | otherwise = return Nothing--mkCCSArray-  :: Interp -> Module -> Int -> [MixEntry_]-  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray interp modul count entries-  | GHCi.interpreterProfiled interp = do-      let module_str = moduleNameString (moduleName modul)-      costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)-      return (listArray (0,count-1) costcentres)-  | otherwise = return (listArray (0,-1) [])- where-    mk_one (srcspan, decl_path, _, _) = (name, src)-      where name = concat (intersperse "." decl_path)-            src = renderWithContext defaultSDocContext (ppr srcspan)---writeMixEntries-  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int-writeMixEntries dflags mod count entries filename-  | not (gopt Opt_Hpc dflags) = return 0-  | otherwise   = do-        let-            hpc_dir = hpcDir dflags-            mod_name = moduleNameString (moduleName mod)--            hpc_mod_dir-              | moduleUnit mod == mainUnit  = hpc_dir-              | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)--            tabStop = 8 -- <tab> counts as a normal char in GHC's-                        -- location ranges.--        createDirectoryIfMissing True hpc_mod_dir-        modTime <- getModificationUTCTime filename-        let entries' = [ (hpcPos, box)-                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]-        when (entries' `lengthIsNot` count) $-          panic "the number of .mix entries are inconsistent"-        let hashNo = mixHash filename modTime tabStop entries'-        mixCreate hpc_mod_dir mod_name-                       $ Mix filename modTime (toHash hashNo) tabStop entries'-        return hashNo----- -------------------------------------------------------------------------------- TickDensity: where to insert ticks--data TickDensity-  = TickForCoverage       -- for Hpc-  | TickForBreakPoints    -- for GHCi-  | TickAllFunctions      -- for -prof-auto-all-  | TickTopFunctions      -- for -prof-auto-top-  | TickExportedFunctions -- for -prof-auto-exported-  | TickCallSites         -- for stack tracing-  deriving Eq--mkDensity :: TickishType -> DynFlags -> TickDensity-mkDensity tickish dflags = case tickish of-  HpcTicks             -> TickForCoverage-  SourceNotes          -> TickForCoverage-  Breakpoints          -> TickForBreakPoints-  ProfNotes ->-    case profAuto dflags of-      ProfAutoAll      -> TickAllFunctions-      ProfAutoTop      -> TickTopFunctions-      ProfAutoExports  -> TickExportedFunctions-      ProfAutoCalls    -> TickCallSites-      _other           -> panic "mkDensity"---- | Decide whether to add a tick to a binding or not.-shouldTickBind  :: TickDensity-                -> Bool         -- top level?-                -> Bool         -- exported?-                -> Bool         -- simple pat bind?-                -> Bool         -- INLINE pragma?-                -> Bool--shouldTickBind density top_lev exported _simple_pat inline- = case density of-      TickForBreakPoints    -> False-        -- we never add breakpoints to simple pattern bindings-        -- (there's always a tick on the rhs anyway).-      TickAllFunctions      -> not inline-      TickTopFunctions      -> top_lev && not inline-      TickExportedFunctions -> exported && not inline-      TickForCoverage       -> True-      TickCallSites         -> False--shouldTickPatBind :: TickDensity -> Bool -> Bool-shouldTickPatBind density top_lev-  = case density of-      TickForBreakPoints    -> False-      TickAllFunctions      -> True-      TickTopFunctions      -> top_lev-      TickExportedFunctions -> False-      TickForCoverage       -> False-      TickCallSites         -> False---- -------------------------------------------------------------------------------- Adding ticks to bindings--addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)-addTickLHsBinds = mapBagM addTickLHsBind--addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds-                                                 , abs_exports = abs_exports-                                                 }))) =-  withEnv add_exports $-    withEnv add_inlines $ do-      binds' <- addTickLHsBinds binds-      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }-  where-   -- in AbsBinds, the Id on each binding is not the actual top-level-   -- Id that we are defining, they are related by the abs_exports-   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need-   -- to add the local Ids to the set of exported Names so that we know to-   -- tick the right bindings.-   add_exports env =-     env{ exports = exports env `extendNameSetList`-                      [ idName mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , idName pid `elemNameSet` (exports env) ] }--   -- See Note [inline sccs]-   add_inlines env =-     env{ inlines = inlines env `extendVarSetList`-                      [ mid-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports-                      , isInlinePragma (idInlinePragma pid) ] }--addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do-  let name = getOccString id-  decl_path <- getPathEntry-  density <- getDensity--  inline_ids <- liftM inlines getEnv-  -- See Note [inline sccs]-  let inline   = isInlinePragma (idInlinePragma id)-                 || id `elemVarSet` inline_ids--  -- See Note [inline sccs]-  tickish <- tickishType `liftM` getEnv-  if inline && tickish == ProfNotes then return (L pos funBind) else do--  (fvs, mg) <--        getFreeVars $-        addPathEntry name $-        addTickMatchGroup False (fun_matches funBind)--  blackListed <- isBlackListed (locA pos)-  exported_names <- liftM exports getEnv--  -- We don't want to generate code for blacklisted positions-  -- We don't want redundant ticks on simple pattern bindings-  -- We don't want to tick non-exported bindings in TickExportedFunctions-  let simple = isSimplePatBind funBind-      toplev = null decl_path-      exported = idName id `elemNameSet` exported_names--  tick <- if not blackListed &&-               shouldTickBind density toplev exported simple inline-             then-                bindTick density name (locA pos) fvs-             else-                return Nothing--  let mbCons = maybe Prelude.id (:)-  return $ L pos $ funBind { fun_matches = mg-                           , fun_tick = tick `mbCons` fun_tick funBind }--   where-   -- a binding is a simple pattern binding if it is a funbind with-   -- zero patterns-   isSimplePatBind :: HsBind GhcTc -> Bool-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0---- TODO: Revisit this-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs-                                    , pat_rhs = rhs }))) = do--  let simplePatId = isSimplePat lhs--  -- TODO: better name for rhs's for non-simple patterns?-  let name = maybe "(...)" getOccString simplePatId--  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs-  let pat' = pat { pat_rhs = rhs'}--  -- Should create ticks here?-  density <- getDensity-  decl_path <- getPathEntry-  let top_lev = null decl_path-  if not (shouldTickPatBind density top_lev)-    then return (L pos pat')-    else do--    let mbCons = maybe id (:)--    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'--    -- Allocate the ticks--    rhs_tick <- bindTick density name (locA pos) fvs-    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks--    patvar_tickss <- case simplePatId of-      Just{} -> return initial_patvar_tickss-      Nothing -> do-        let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)-        patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars-        return-          (zipWith mbCons patvar_ticks-                          (initial_patvar_tickss ++ repeat []))--    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }---- Only internal stuff, not from source, uses VarBind, so we ignore it.-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind--bindTick-  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)-bindTick density name pos fvs = do-  decl_path <- getPathEntry-  let-      toplev        = null decl_path-      count_entries = toplev || density == TickAllFunctions-      top_only      = density /= TickAllFunctions-      box_label     = if toplev then TopLevelBox [name]-                                else LocalBox (decl_path ++ [name])-  ---  allocATickBox box_label count_entries top_only pos fvs----- Note [inline sccs]--- ~~~~~~~~~~~~~~~~~~--- The reason not to add ticks to INLINE functions is that this is--- sometimes handy for avoiding adding a tick to a particular function--- (see #6131)------ So for now we do not add any ticks to INLINE functions at all.------ We used to use isAnyInlinePragma to figure out whether to avoid adding--- ticks for this purpose. However, #12962 indicates that this contradicts--- the documentation on profiling (which only mentions INLINE pragmas).--- So now we're more careful about what we avoid adding ticks to.---- -------------------------------------------------------------------------------- Decorate an LHsExpr with ticks---- selectively add ticks to interesting expressions-addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExpr e@(L pos e0) = do-  d <- getDensity-  case d of-    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it-    TickForCoverage    -> tick_it-    TickCallSites      | isCallSite e0      -> tick_it-    _other             -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)-                  $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- Add a tick to an expression which is the RHS of an equation or a binding.--- We always consider these to be breakpoints, unless the expression is a 'let'--- (because the body will definitely have a tick somewhere).  ToDo: perhaps--- we should treat 'case' and 'if' the same way?-addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprRHS e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     TickForCoverage -> tick_it-     TickCallSites   | isCallSite e0 -> tick_it-     _other          -> dont_tick_it- where-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)-                  $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- The inner expression of an evaluation context:---    let binds in [], ( [] )--- we never tick these if we're doing HPC, but otherwise--- we treat it like an ordinary expression.-addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprEvalInner e = do-   d <- getDensity-   case d of-     TickForCoverage -> addTickLHsExprNever e-     _otherwise      -> addTickLHsExpr e---- | A let body is treated differently from addTickLHsExprEvalInner--- above with TickForBreakPoints, because for breakpoints we always--- want to tick the body, even if it is not a redex.  See test--- break012.  This gives the user the opportunity to inspect the--- values of the let-bound variables.-addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprLetBody e@(L pos e0) = do-  d <- getDensity-  case d of-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it-                        | otherwise     -> tick_it-     _other -> addTickLHsExprEvalInner e- where-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)-                  $ addTickHsExpr e0-   dont_tick_it = addTickLHsExprNever e---- version of addTick that does not actually add a tick,--- because the scope of this tick is completely subsumed by--- another.-addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprNever (L pos e0) = do-    e1 <- addTickHsExpr e0-    return $ L pos e1---- General heuristic: expressions which are calls (do not denote--- values) are good break points.-isGoodBreakExpr :: HsExpr GhcTc -> Bool-isGoodBreakExpr e = isCallSite e--isCallSite :: HsExpr GhcTc -> Bool-isCallSite HsApp{}     = True-isCallSite HsAppType{} = True-isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))-                       = isCallSite e--- NB: OpApp, SectionL, SectionR are all expanded out-isCallSite _           = False--addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprOptAlt oneOfMany (L pos e0)-  = ifDensity TickForCoverage-        (allocTickBox (ExpBox oneOfMany) False False (locA pos)-          $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))--addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addBinTickLHsExpr boxLabel (L pos e0)-  = ifDensity TickForCoverage-        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))----- -------------------------------------------------------------------------------- Decorate the body of an HsExpr with ticks.--- (Whether to put a tick around the whole expression was already decided,--- in the addTickLHsExpr family of functions.)--addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)-addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e-addTickHsExpr e@(HsUnboundVar {})   = return e-addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e--addTickHsExpr e@(HsIPVar {})            = return e-addTickHsExpr e@(HsOverLit {})          = return e-addTickHsExpr e@(HsOverLabel{})         = return e-addTickHsExpr e@(HsLit {})              = return e-addTickHsExpr (HsLam x mg)              = liftM (HsLam x)-                                                (addTickMatchGroup True mg)-addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)-                                                   (addTickMatchGroup True mgs)-addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)-                                                          (addTickLHsExpr      e2)-addTickHsExpr (HsAppType x e ty)       = liftM3 HsAppType (return x)-                                                          (addTickLHsExprNever e)-                                                          (return ty)-addTickHsExpr (OpApp fix e1 e2 e3) =-        liftM4 OpApp-                (return fix)-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-                (addTickLHsExpr e3)-addTickHsExpr (NegApp x e neg) =-        liftM2 (NegApp x)-                (addTickLHsExpr e)-                (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar x lpar e rpar) = do-        e' <- addTickLHsExprEvalInner e-        return (HsPar x lpar e' rpar)-addTickHsExpr (SectionL x e1 e2) =-        liftM2 (SectionL x)-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-addTickHsExpr (SectionR x e1 e2) =-        liftM2 (SectionR x)-                (addTickLHsExprNever e1)-                (addTickLHsExpr e2)-addTickHsExpr (ExplicitTuple x es boxity) =-        liftM2 (ExplicitTuple x)-                (mapM addTickTupArg es)-                (return boxity)-addTickHsExpr (ExplicitSum ty tag arity e) = do-        e' <- addTickLHsExpr e-        return (ExplicitSum ty tag arity e')-addTickHsExpr (HsCase x e mgs) =-        liftM2 (HsCase x)-                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily-                                   -- be evaluated.-                (addTickMatchGroup False mgs)-addTickHsExpr (HsIf x e1 e2 e3) =-        liftM3 (HsIf x)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsExprOptAlt True e2)-                (addTickLHsExprOptAlt True e3)-addTickHsExpr (HsMultiIf ty alts)-  = do { let isOneOfMany = case alts of [_] -> False; _ -> True-       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts-       ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x tkLet binds tkIn e) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.-          e' <- addTickLHsExprLetBody e-          return (HsLet x tkLet binds' tkIn e')-addTickHsExpr (HsDo srcloc cxt (L l stmts))-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())-       ; return (HsDo srcloc cxt (L l stmts')) }-  where-        forQual = case cxt of-                    ListComp -> Just $ BinBox QualBinBox-                    _        -> Nothing-addTickHsExpr (ExplicitList ty es)-  = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)--addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e--addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })-  = do { rec_binds' <- addTickHsRecordBinds rec_binds-       ; return (expr { rcon_flds = rec_binds' }) }--addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) }-addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) }--addTickHsExpr (ExprWithTySig x e ty) =-        liftM3 ExprWithTySig-                (return x)-                (addTickLHsExprNever e) -- No need to tick the inner expression-                                        -- for expressions with signatures-                (return ty)-addTickHsExpr (ArithSeq ty wit arith_seq) =-        liftM3 ArithSeq-                (return ty)-                (addTickWit wit)-                (addTickArithSeqInfo arith_seq)-             where addTickWit Nothing = return Nothing-                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl-                                             return (Just fl')--addTickHsExpr (HsPragE x p e) =-        liftM (HsPragE x p) (addTickLHsExpr e)-addTickHsExpr e@(HsTypedBracket {})  = return e-addTickHsExpr e@(HsUntypedBracket{}) = return e-addTickHsExpr e@(HsSpliceE  {})      = return e-addTickHsExpr e@(HsGetField {})      = return e-addTickHsExpr e@(HsProjection {})    = return e-addTickHsExpr (HsProc x pat cmdtop) =-        liftM2 (HsProc x)-                (addTickLPat pat)-                (liftL (addTickHsCmdTop) cmdtop)-addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =-        liftM (XExpr . WrapExpr . HsWrap w) $-              (addTickHsExpr e)        -- Explicitly no tick on inside-addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =-        liftM (XExpr . ExpansionExpr . HsExpanded a) $-              (addTickHsExpr b)--addTickHsExpr e@(XExpr (ConLikeTc {})) = return e-  -- We used to do a freeVar on a pat-syn builder, but actually-  -- such builders are never in the inScope env, which-  -- doesn't include top level bindings---- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (XExpr (HsTick t e)) =-        liftM (XExpr . HsTick t) (addTickLHsExprNever e)-addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =-        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)--addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)-addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e-                                  ; return (Present x e') }-addTickTupArg (Missing ty) = return (Missing ty)---addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)-                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do-  let isOneOfMany = matchesOneOfMany matches-  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches-  return $ mg { mg_alts = L l matches' }--addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)-             -> TM (Match GhcTc (LHsExpr GhcTc))-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats-                                               , m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs-    return $ match { m_grhss = gRHSs' }--addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)-             -> TM (GRHSs GhcTc (LHsExpr GhcTc))-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded-    return $ GRHSs x guarded' local_binds'-  where-    binders = collectLocalBinders CollNoDictBinders local_binds--addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)-            -> TM (GRHS GhcTc (LHsExpr GhcTc))-addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts-                        (addTickGRHSBody isOneOfMany isLambda expr)-  return $ GRHS x stmts' expr'--addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do-  d <- getDensity-  case d of-    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr-    TickAllFunctions | isLambda ->-       addPathEntry "\\" $-         allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $-           addTickHsExpr e0-    _otherwise ->-       addTickLHsExprRHS expr--addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]-              -> TM [ExprLStmt GhcTc]-addTickLStmts isGuard stmts = do-  (stmts, _) <- addTickLStmts' isGuard stmts (return ())-  return stmts--addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a-               -> TM ([ExprLStmt GhcTc], a)-addTickLStmts' isGuard lstmts res-  = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $-    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts-       ; a <- res-       ; return (lstmts', a) }--addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)-            -> TM (Stmt GhcTc (LHsExpr GhcTc))-addTickStmt _isGuard (LastStmt x e noret ret) =-        liftM3 (LastStmt x)-                (addTickLHsExpr e)-                (pure noret)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickStmt _isGuard (BindStmt xbs pat e) =-        liftM4 (\b f -> BindStmt $ XBindStmtTc-                    { xbstc_bindOp = b-                    , xbstc_boundResultType = xbstc_boundResultType xbs-                    , xbstc_boundResultMult = xbstc_boundResultMult xbs-                    , xbstc_failOp = f-                    })-                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))-                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))-                (addTickLPat pat)-                (addTickLHsExprRHS e)-addTickStmt isGuard (BodyStmt x e bind' guard') =-        liftM3 (BodyStmt x)-                (addTick isGuard e)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-addTickStmt _isGuard (LetStmt x binds) =-        liftM (LetStmt x)-                (addTickHsLocalBinds binds)-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =-    liftM3 (ParStmt x)-        (mapM (addTickStmtAndBinders isGuard) pairs)-        (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))-        (addTickSyntaxExpr hpcSrcSpan bindExpr)-addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do-    args' <- mapM (addTickApplicativeArg isGuard) args-    return (ApplicativeStmt body_ty args' mb_join)--addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts-                                    , trS_by = by, trS_using = using-                                    , trS_ret = returnExpr, trS_bind = bindExpr-                                    , trS_fmap = liftMExpr }) = do-    t_s <- addTickLStmts isGuard stmts-    t_y <- fmapMaybeM  addTickLHsExprRHS by-    t_u <- addTickLHsExprRHS using-    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr-    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr-    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))-    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u-                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }--addTickStmt isGuard stmt@(RecStmt {})-  = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }--addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e-                  | otherwise          = addTickLHsExprRHS e--addTickApplicativeArg-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)-addTickApplicativeArg isGuard (op, arg) =-  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)- where-  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =-    ApplicativeArgOne-      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail-      <*> addTickLPat pat-      <*> addTickLHsExpr expr-      <*> pure isBody-  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =-    (ApplicativeArgMany x)-      <$> addTickLStmts isGuard stmts-      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))-      <*> addTickLPat pat-      <*> pure ctxt--addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc-                      -> TM (ParStmtBlock GhcTc GhcTc)-addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =-    liftM3 (ParStmtBlock x)-        (addTickLStmts isGuard stmts)-        (return ids)-        (addTickSyntaxExpr hpcSrcSpan returnExpr)--addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)-addTickHsLocalBinds (HsValBinds x binds) =-        liftM (HsValBinds x)-                (addTickHsValBinds binds)-addTickHsLocalBinds (HsIPBinds x binds)  =-        liftM (HsIPBinds x)-                (addTickHsIPBinds binds)-addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)--addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)-                  -> TM (HsValBindsLR GhcTc (GhcPass b))-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do-        b <- liftM2 NValBinds-                (mapM (\ (rec,binds') ->-                                liftM2 (,)-                                        (return rec)-                                        (addTickLHsBinds binds'))-                        binds)-                (return sigs)-        return $ XValBindsLR b-addTickHsValBinds _ = panic "addTickHsValBinds"--addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)-addTickHsIPBinds (IPBinds dictbinds ipbinds) =-        liftM2 IPBinds-                (return dictbinds)-                (mapM (liftL (addTickIPBind)) ipbinds)--addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)-addTickIPBind (IPBind x nm e) =-        liftM (IPBind x nm)-               (addTickLHsExpr e)---- There is no location here, so we might need to use a context location??-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)-addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do-        x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))-        return $ syn { syn_expr = x' }-addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc---- we do not walk into patterns.-addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)-addTickLPat pat = return pat--addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)-addTickHsCmdTop (HsCmdTop x cmd) =-        liftM2 HsCmdTop-                (return x)-                (addTickLHsCmd cmd)--addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)-addTickLHsCmd (L pos c0) = do-        c1 <- addTickHsCmd c0-        return $ L pos c1--addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)-addTickHsCmd (HsCmdLam x matchgroup) =-        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)-addTickHsCmd (HsCmdApp x c e) =-        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)-{--addTickHsCmd (OpApp e1 c2 fix c3) =-        liftM4 OpApp-                (addTickLHsExpr e1)-                (addTickLHsCmd c2)-                (return fix)-                (addTickLHsCmd c3)--}-addTickHsCmd (HsCmdPar x lpar e rpar) = do-        e' <- addTickLHsCmd e-        return (HsCmdPar x lpar e' rpar)-addTickHsCmd (HsCmdCase x e mgs) =-        liftM2 (HsCmdCase x)-                (addTickLHsExpr e)-                (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdLamCase x lc_variant mgs) =-        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =-        liftM3 (HsCmdIf x cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsCmd c2)-                (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.-          c' <- addTickLHsCmd c-          return (HsCmdLet x tkLet binds' tkIn c')-addTickHsCmd (HsCmdDo srcloc (L l stmts))-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())-       ; return (HsCmdDo srcloc (L l stmts')) }--addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =-        liftM5 HsCmdArrApp-               (return arr_ty)-               (addTickLHsExpr e1)-               (addTickLHsExpr e2)-               (return ty1)-               (return lr)-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =-        liftM4 (HsCmdArrForm x)-               (addTickLHsExpr e)-               (return f)-               (return fix)-               (mapM (liftL (addTickHsCmdTop)) cmdtop)--addTickHsCmd (XCmd (HsWrap w cmd)) =-  liftM XCmd $-  liftM (HsWrap w) (addTickHsCmd cmd)---- Others should never happen in a command context.---addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)--addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)-                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))-addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do-  matches' <- mapM (liftL addTickCmdMatch) matches-  return $ mg { mg_alts = L l matches' }--addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))-addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do-    gRHSs' <- addTickCmdGRHSs gRHSs-    return $ match { m_grhss = gRHSs' }--addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))-addTickCmdGRHSs (GRHSs x guarded local_binds) =-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL addTickCmdGRHS) guarded-    return $ GRHSs x guarded' local_binds'-  where-    binders = collectLocalBinders CollNoDictBinders local_binds--addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))--- The *guards* are *not* Cmds, although the body is--- C.f. addTickGRHS for the BinBox stuff-addTickCmdGRHS (GRHS x stmts cmd)-  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)-                                   stmts (addTickLHsCmd cmd)-       ; return $ GRHS x stmts' expr' }--addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]-                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]-addTickLCmdStmts stmts = do-  (stmts, _) <- addTickLCmdStmts' stmts (return ())-  return stmts--addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a-                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)-addTickLCmdStmts' lstmts res-  = bindLocals binders $ do-        lstmts' <- mapM (liftL addTickCmdStmt) lstmts-        a <- res-        return (lstmts', a)-  where-        binders = collectLStmtsBinders CollNoDictBinders lstmts--addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))-addTickCmdStmt (BindStmt x pat c) =-        liftM2 (BindStmt x)-                (addTickLPat pat)-                (addTickLHsCmd c)-addTickCmdStmt (LastStmt x c noret ret) =-        liftM3 (LastStmt x)-                (addTickLHsCmd c)-                (pure noret)-                (addTickSyntaxExpr hpcSrcSpan ret)-addTickCmdStmt (BodyStmt x c bind' guard') =-        liftM3 (BodyStmt x)-                (addTickLHsCmd c)-                (addTickSyntaxExpr hpcSrcSpan bind')-                (addTickSyntaxExpr hpcSrcSpan guard')-addTickCmdStmt (LetStmt x binds) =-        liftM (LetStmt x)-                (addTickHsLocalBinds binds)-addTickCmdStmt stmt@(RecStmt {})-  = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }-addTickCmdStmt ApplicativeStmt{} =-  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"---- Others should never happen in a command context.-addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)--addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)-addTickHsRecordBinds (HsRecFields fields dd)-  = do  { fields' <- mapM addTickHsRecField fields-        ; return (HsRecFields fields' dd) }--addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)-                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))-addTickHsRecField (L l (HsFieldBind x id expr pun))-        = do { expr' <- addTickLHsExpr expr-             ; return (L l (HsFieldBind x id expr' pun)) }--addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)-addTickArithSeqInfo (From e1) =-        liftM From-                (addTickLHsExpr e1)-addTickArithSeqInfo (FromThen e1 e2) =-        liftM2 FromThen-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromTo e1 e2) =-        liftM2 FromTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-addTickArithSeqInfo (FromThenTo e1 e2 e3) =-        liftM3 FromThenTo-                (addTickLHsExpr e1)-                (addTickLHsExpr e2)-                (addTickLHsExpr e3)--data TickTransState = TT { tickBoxCount:: !Int-                         , mixEntries  :: [MixEntry_]-                         , ccIndices   :: !CostCentreState-                         }--addMixEntry :: MixEntry_ -> TM Int-addMixEntry ent = do-  c <- tickBoxCount <$> getState-  setState $ \st ->-    st { tickBoxCount = c + 1-       , mixEntries = ent : mixEntries st-       }-  return c--data TickTransEnv = TTE { fileName     :: FastString-                        , density      :: TickDensity-                        , tte_countEntries :: !Bool-                          -- ^ Whether the number of times functions are-                          -- entered should be counted.-                        , exports      :: NameSet-                        , inlines      :: VarSet-                        , declPath     :: [String]-                        , inScope      :: VarSet-                        , blackList    :: Set RealSrcSpan-                        , this_mod     :: Module-                        , tickishType  :: TickishType-                        }----      deriving Show--data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes-                 deriving (Eq)--coveragePasses :: DynFlags -> [TickishType]-coveragePasses dflags =-    ifa (breakpointsEnabled dflags)          Breakpoints $-    ifa (gopt Opt_Hpc dflags)                HpcTicks $-    ifa (sccProfilingEnabled dflags &&-         profAuto dflags /= NoProfAuto)      ProfNotes $-    ifa (needSourceNotes dflags)          SourceNotes []-  where ifa f x xs | f         = x:xs-                   | otherwise = xs---- | Should we produce 'Breakpoint' ticks?-breakpointsEnabled :: DynFlags -> Bool-breakpointsEnabled dflags = backendWantsBreakpointTicks (backend dflags)---- | Tickishs that only make sense when their source code location--- refers to the current file. This might not always be true due to--- LINE pragmas in the code - which would confuse at least HPC.-tickSameFileOnly :: TickishType -> Bool-tickSameFileOnly HpcTicks = True-tickSameFileOnly _other   = False--type FreeVars = OccEnv Id-noFVs :: FreeVars-noFVs = emptyOccEnv---- Note [freevars]--- ~~~~~~~~~~~~~~~---   For breakpoints we want to collect the free variables of an---   expression for pinning on the HsTick.  We don't want to collect---   *all* free variables though: in particular there's no point pinning---   on free variables that are will otherwise be in scope at the GHCi---   prompt, which means all top-level bindings.  Unfortunately detecting---   top-level bindings isn't easy (collectHsBindsBinders on the top-level---   bindings doesn't do it), so we keep track of a set of "in-scope"---   variables in addition to the free variables, and the former is used---   to filter additions to the latter.  This gives us complete control---   over what free variables we track.--newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }-    deriving (Functor)-        -- a combination of a state monad (TickTransState) and a writer-        -- monad (FreeVars).--instance Applicative TM where-    pure a = TM $ \ _env st -> (a,noFVs,st)-    (<*>) = ap--instance Monad TM where-  (TM m) >>= k = TM $ \ env st ->-                                case m env st of-                                  (r1,fv1,st1) ->-                                     case unTM (k r1) env st1 of-                                       (r2,fv2,st2) ->-                                          (r2, fv1 `plusOccEnv` fv2, st2)---- | Get the next HPC cost centre index for a given centre name-getCCIndexM :: FastString -> TM CostCentreIndex-getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $-                                                 ccIndices st-                              in (idx, noFVs, st { ccIndices = is' })--getState :: TM TickTransState-getState = TM $ \ _ st -> (st, noFVs, st)--setState :: (TickTransState -> TickTransState) -> TM ()-setState f = TM $ \ _ st -> ((), noFVs, f st)--getEnv :: TM TickTransEnv-getEnv = TM $ \ env st -> (env, noFVs, st)--withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a-withEnv f (TM m) = TM $ \ env st ->-                                 case m (f env) st of-                                   (a, fvs, st') -> (a, fvs, st')--getDensity :: TM TickDensity-getDensity = TM $ \env st -> (density env, noFVs, st)--ifDensity :: TickDensity -> TM a -> TM a -> TM a-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el--getFreeVars :: TM a -> TM (FreeVars, a)-getFreeVars (TM m)-  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')--freeVar :: Id -> TM ()-freeVar id = TM $ \ env st ->-                if id `elemVarSet` inScope env-                   then ((), unitOccEnv (nameOccName (idName id)) id, st)-                   else ((), noFVs, st)--addPathEntry :: String -> TM a -> TM a-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })--getPathEntry :: TM [String]-getPathEntry = declPath `liftM` getEnv--getFileName :: TM FastString-getFileName = fileName `liftM` getEnv--isGoodSrcSpan' :: SrcSpan -> Bool-isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos-isGoodSrcSpan' (UnhelpfulSpan _) = False--isGoodTickSrcSpan :: SrcSpan -> TM Bool-isGoodTickSrcSpan pos = do-  file_name <- getFileName-  tickish <- tickishType `liftM` getEnv-  let need_same_file = tickSameFileOnly tickish-      same_file      = Just file_name == srcSpanFileName_maybe pos-  return (isGoodSrcSpan' pos && (not need_same_file || same_file))--ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a-ifGoodTickSrcSpan pos then_code else_code = do-  good <- isGoodTickSrcSpan pos-  if good then then_code else else_code--bindLocals :: [Id] -> TM a -> TM a-bindLocals new_ids (TM m)-  = TM $ \ env st ->-                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of-                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')-  where occs = [ nameOccName (idName id) | id <- new_ids ]--isBlackListed :: SrcSpan -> TM Bool-isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)-isBlackListed (UnhelpfulSpan _) = return False---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)-             -> TM (LHsExpr GhcTc)-allocTickBox boxLabel countEntries topOnly pos m =-  ifGoodTickSrcSpan pos (do-    (fvs, e) <- getFreeVars m-    env <- getEnv-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))-  ) (do-    e <- m-    return (L (noAnnSrcSpan pos) e)-  )---- the tick application inherits the source position of its--- expression argument to support nested box allocations-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars-              -> TM (Maybe CoreTickish)-allocATickBox boxLabel countEntries topOnly  pos fvs =-  ifGoodTickSrcSpan pos (do-    let-      mydecl_path = case boxLabel of-                      TopLevelBox x -> x-                      LocalBox xs  -> xs-                      _ -> panic "allocATickBox"-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path-    return (Just tickish)-  ) (return Nothing)---mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]-          -> TM CoreTickish-mkTickish boxLabel countEntries topOnly pos fvs decl_path = do--  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs-          -- unlifted types cause two problems here:-          --   * we can't bind them  at the GHCi prompt-          --     (bindLocalsAtBreakpoint already filters them out),-          --   * the simplifier might try to substitute a literal for-          --     the Id, and we can't handle that.--      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)--      cc_name | topOnly   = head decl_path-              | otherwise = concat (intersperse "." decl_path)--  env <- getEnv-  case tickishType env of-    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me--    ProfNotes -> do-      let nm = mkFastString cc_name-      flavour <- HpcCC <$> getCCIndexM nm-      let cc = mkUserCC nm (this_mod env) pos flavour-          count = countEntries && tte_countEntries env-      return $ ProfNote cc count True{-scopes-}--    Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids--    SourceNotes | RealSrcSpan pos' _ <- pos ->-      return $ SourceNote pos' cc_name--    _otherwise -> panic "mkTickish: bad source span!"---allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)-                -> TM (LHsExpr GhcTc)-allocBinTickBox boxLabel pos m = do-  env <- getEnv-  case tickishType env of-    HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m-                   ifGoodTickSrcSpan pos-                     (mkBinTickBoxHpc boxLabel pos e)-                     (return e)-    _other   -> allocTickBox (ExpBox False) False False pos m--mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc-                -> TM (LHsExpr GhcTc)-mkBinTickBoxHpc boxLabel pos e = do-  env <- getEnv-  binTick <- HsBinTick-    <$> addMixEntry (pos,declPath env, [],boxLabel True)-    <*> addMixEntry (pos,declPath env, [],boxLabel False)-    <*> pure e-  tick <- HpcTick (this_mod env)-    <$> addMixEntry (pos,declPath env, [],ExpBox False)-  let pos' = noAnnSrcSpan pos-  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))--mkHpcPos :: SrcSpan -> HpcPos-mkHpcPos pos@(RealSrcSpan s _)-   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,-                                    srcSpanStartCol s,-                                    srcSpanEndLine s,-                                    srcSpanEndCol s - 1)-                              -- the end column of a SrcSpan is one-                              -- greater than the last column of the-                              -- span (see SrcLoc), whereas HPC-                              -- expects to the column range to be-                              -- inclusive, hence we subtract one above.-mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"--hpcSrcSpan :: SrcSpan-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")--matchesOneOfMany :: [LMatch GhcTc body] -> Bool-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1-  where-        matchCount :: LMatch GhcTc body -> Int-        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))-          = length grhss--type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)---- For the hash value, we hash everything: the file name,---  the timestamp of the original source file, the tab stop,---  and the mix entries. We cheat, and hash the show'd string.--- This hash only has to be hashed at Mix creation time,--- and is for sanity checking only.--mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int-mixHash file tm tabstop entries = fromIntegral $ hashString-        (show $ Mix file tm 0 tabstop entries)--{--************************************************************************-*                                                                      *-*              initialisation-*                                                                      *-************************************************************************--Each module compiled with -fhpc declares an initialisation function of-the form `hpc_init_<module>()`, which is emitted into the _stub.c file-and annotated with __attribute__((constructor)) so that it gets-executed at startup time.--The function's purpose is to call hs_hpc_module to register this-module with the RTS, and it looks something like this:--static void hpc_init_Main(void) __attribute__((constructor));-static void hpc_init_Main(void)-{extern StgWord64 _hpc_tickboxes_Main_hpc[];- hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}--}-+{-+(c) Galois, 2006+(c) University of Glasgow, 2007+-}++module GHC.HsToCore.Coverage+  ( writeMixEntries+  , hpcInitCode+  ) where++import GHC.Prelude as Prelude++import GHC.Unit++import GHC.HsToCore.Ticks++import GHC.Platform++import GHC.Data.FastString+import GHC.Data.SizedSeq++import GHC.Cmm.CLabel++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Types.ForeignStubs+import GHC.Types.HpcInfo+import GHC.Types.SrcLoc++import Control.Monad+import Data.Time+import System.Directory++import Trace.Hpc.Mix+import Trace.Hpc.Util++import qualified Data.ByteString as BS++writeMixEntries+  :: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int+writeMixEntries hpc_dir mod extendedMixEntries filename+  = do+        let count = fromIntegral $ sizeSS extendedMixEntries+            entries = ssElts extendedMixEntries++            mod_name = moduleNameString (moduleName mod)++            hpc_mod_dir+              | moduleUnit mod == mainUnit  = hpc_dir+              | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)++            tabStop = 8 -- <tab> counts as a normal char in GHC's+                        -- location ranges.++        createDirectoryIfMissing True hpc_mod_dir+        modTime <- getModificationUTCTime filename+        let entries' = [ (hpcPos, tick_label t)+                       | t <- entries, hpcPos <- [mkHpcPos $ tick_loc t] ]+        when (entries' `lengthIsNot` count) $+          panic "the number of .mix entries are inconsistent"+        let hashNo = mixHash filename modTime tabStop entries'+        mixCreate hpc_mod_dir mod_name+                       $ Mix filename modTime (toHash hashNo) tabStop entries'+        return hashNo++mkHpcPos :: SrcSpan -> HpcPos+mkHpcPos pos@(RealSrcSpan s _)+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,+                                    srcSpanStartCol s,+                                    srcSpanEndLine s,+                                    srcSpanEndCol s - 1)+                              -- the end column of a SrcSpan is one+                              -- greater than the last column of the+                              -- span (see SrcLoc), whereas HPC+                              -- expects to the column range to be+                              -- inclusive, hence we subtract one above.+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"++-- For the hash value, we hash everything: the file name,+--  the timestamp of the original source file, the tab stop,+--  and the mix entries. We cheat, and hash the show'd string.+-- This hash only has to be hashed at Mix creation time,+-- and is for sanity checking only.+mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int+mixHash file tm tabstop entries = fromIntegral $ hashString+        (show $ Mix file tm 0 tabstop entries)++{-+************************************************************************+*                                                                      *+*              initialisation+*                                                                      *+************************************************************************+-}++{- | Create HPC initialization C code for a module++Each module compiled with -fhpc declares an initialisation function of+the form `hpc_init_<module>()`, which is emitted into the _stub.c file+and annotated with __attribute__((constructor)) so that it gets+executed at startup time.++The function's purpose is to call hs_hpc_module to register this+module with the RTS, and it looks something like this:++> static void hpc_init_Main(void) __attribute__((constructor));+> static void hpc_init_Main(void)+> {+>   extern StgWord64 _hpc_tickboxes_Main_hpc[];+>   hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);+> }+-} hpcInitCode :: Platform -> Module -> HpcInfo -> CStub hpcInitCode _ _ (NoHpcInfo {}) = mempty hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
compiler/GHC/HsToCore/Expr.hs view
@@ -487,9 +487,10 @@ -- Template Haskell stuff -- See Note [The life cycle of a TH quotation] -dsExpr (HsTypedBracket   (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps-dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps-dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)+dsExpr (HsTypedBracket   bracket_tc _) = dsBracket bracket_tc+dsExpr (HsUntypedBracket bracket_tc _) = dsBracket bracket_tc+dsExpr (HsTypedSplice   _   s) = pprPanic "dsExpr:typed splice" (pprTypedSplice Nothing s)+dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext  -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd@@ -772,23 +773,21 @@   | otherwise   = pprPanic "dsConLike" (ppr ps) -dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr--- This function desugars ConLikeTc+-- | This function desugars 'ConLikeTc': it eta-expands+-- data constructors to make linear types work.+-- -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head---     for what is going on here+dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr dsConLike con tvs tys   = do { ds_con <- dsHsConLike con        ; ids    <- newSysLocalsDs tys-                   -- newSysLocalDs: /can/ be lev-poly; see+           -- NB: these 'Id's may be representation-polymorphic;+           -- see Wrinkle [Representation-polymorphic lambda] in+           -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.        ; return (mkLams tvs $                  mkLams ids $                  ds_con `mkTyApps` mkTyVarTys tvs-                        `mkVarApps` drop_stupid ids) }-  where--    drop_stupid = dropList (conLikeStupidTheta con)-    -- drop_stupid: see Note [Instantiating stupid theta]-    --              in GHC.Tc.Gen.Head+                        `mkVarApps` ids) }  {- ************************************************************************@@ -842,7 +841,7 @@        = go wrap hs_e     go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))        = go (wrap1 <.> wrap2) hs_e-    go wrap (HsAppType ty (L _ hs_e) _)+    go wrap (HsAppType ty (L _ hs_e) _ _)        = go (wrap <.> WpTyApp ty) hs_e      go wrap (HsVar _ (L _ var))
compiler/GHC/HsToCore/Match.hs view
@@ -430,7 +430,7 @@          -- case v of { x@p -> mr[] }         -- = case v of { p -> let x=v in mr[] }-tidy1 v o (AsPat _ (L _ var) pat)+tidy1 v o (AsPat _ (L _ var) _ pat)   = do  { (wrap, pat') <- tidy1 v o (unLoc pat)         ; return (wrapBind var v . wrap, pat') } @@ -517,8 +517,8 @@  -- Push the bang-pattern inwards, in the hope that -- it may disappear next time-tidy_bang_pat v o l (AsPat x v' p)-  = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))+tidy_bang_pat v o l (AsPat x v' at p)+  = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p))) tidy_bang_pat v o l (XPat (CoPat w p t))   = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -119,7 +119,7 @@    -- (x@pat)   ==>   Desugar pat with x as match var and handle impedance   --                 mismatch with incoming match var-  AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p+  AsPat _ (L _ y) _ p -> (mkPmLetVar y x ++) <$> desugarLPat y p    SigPat _ p _ty -> desugarLPat x p
compiler/GHC/HsToCore/Quote.hs view
@@ -157,36 +157,32 @@ getPlatform = targetPlatform <$> getDynFlags  ------------------------------------------------------------------------------dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr-          -> HsQuote GhcRn      -- See Note [The life cycle of a TH quotation]-          -> [PendingTcSplice]-          -> DsM CoreExpr+dsBracket :: HsBracketTc -> 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+dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote = quote })+  = case quote of+      VarBr _ _ n -> do { MkC e1  <- lookupOccDsM (unLoc n) ; return e1 }+      ExpBr _ e   -> runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }+      PatBr _ p   -> runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }+      TypBr _ t   -> runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }+      DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }+      DecBrL {}   -> panic "dsUntypedBracket: unexpected DecBrL"   where-    runOverloaded act = do+    Just wrap = mb_wrap  -- Not used in VarBr case       -- In the overloaded case we have to get given a wrapper, it is just-      -- for variable quotations that there is no wrapper, because they+      -- the VarBr case that there is no wrapper, because they       -- have a simple type.-      mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)-      runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw +    runOverloaded act = do { mw <- mkMetaWrappers 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 (unLoc 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 "dsUntypedBracket: unexpected DecBrL"-- {- Note [Desugaring Brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1413,7 +1409,8 @@                                 t1 <- repLTy t                                 k1 <- repLTy k                                 repTSig t1 k1-repTy (HsSpliceTy _ splice)      = repSplice splice+repTy (HsSpliceTy (HsUntypedSpliceNested n) _) = rep_splice n+repTy t@(HsSpliceTy (HsUntypedSpliceTop _ _) _) = pprPanic "repTy: top level splice" (ppr t) repTy (HsExplicitListTy _ _ tys) = do                                     tys1 <- repLTys tys                                     repTPromotedList tys1@@ -1460,13 +1457,8 @@ --              Splices ----------------------------------------------------------------------------- -repSplice :: HsSplice GhcRn -> MetaM (Core a) -- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice -- 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)  rep_splice :: Name -> MetaM (Core a) rep_splice splice_name@@ -1519,7 +1511,8 @@                         ; core_ms <- coreListM matchTyConName ms'                         ; repLamCases core_ms } repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}-repE (HsAppType _ e t) = do { a <- repLE e+repE (HsAppType _ e _ t)+                       = do { a <- repLE e                             ; s <- repLTy (hswc_body t)                             ; repAppType a s } @@ -1634,7 +1627,9 @@                              ds3 <- repLE e3                              repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE _ splice)  = repSplice splice+repE (HsTypedSplice n _) = rep_splice n+repE (HsUntypedSplice (HsUntypedSpliceNested n) _)  = rep_splice n+repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e) repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC repE (HsUnboundVar _ uv)   = do                                occ   <- occNameLit uv@@ -2061,7 +2056,7 @@ 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' <- lookupNBinder x; p1 <- repLP p+repP (AsPat _ x _ p)    = do { x' <- lookupNBinder x; p1 <- repLP p                              ; repPaspat x' p1 } repP (ParPat _ _ p _)   = repLP p repP (ListPat _ ps)     = do { qs <- repLPs ps; repPlist qs }@@ -2074,7 +2069,8 @@  = do { con_str <- lookupLOcc dc       ; case details of          PrefixCon tyargs ps -> do { qs <- repLPs ps-                                   ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs+                                   ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hsps_body t)+                                   ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs                                    ; repPcon con_str ts qs }          RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)                             ; repPrec con_str fps }@@ -2101,7 +2097,8 @@ repP (SigPat _ p t) = do { p' <- repLP p                          ; t' <- repLTy (hsPatSigType t)                          ; repPsig p' t' }-repP (SplicePat _ splice) = repSplice splice+repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n+repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p) repP other = notHandled (ThExoticPattern other)  ----------------------------------------------------------
+ compiler/GHC/HsToCore/Ticks.hs view
@@ -0,0 +1,1240 @@+{-# LANGUAGE DeriveFunctor            #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeFamilies             #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++{-+(c) Galois, 2006+(c) University of Glasgow, 2007+-}++module GHC.HsToCore.Ticks+  ( TicksConfig (..)+  , Tick (..)+  , TickishType (..)+  , addTicksToBinds+  , isGoodSrcSpan'+  ) where++import GHC.Prelude as Prelude++import GHC.Hs+import GHC.Unit++import GHC.Core.Type+import GHC.Core.TyCon++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.Bag+import GHC.Data.SizedSeq++import GHC.Driver.Flags (DumpFlag(..))++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Monad+import GHC.Utils.Logger+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Var.Set+import GHC.Types.Name.Set hiding (FreeVars)+import GHC.Types.Name+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.Tickish+import GHC.Types.ProfAuto++import Control.Monad+import Data.List (isSuffixOf, intersperse)++import Trace.Hpc.Mix++import Data.Set (Set)+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+*              The main function: addTicksToBinds+*                                                                      *+************************************************************************+-}++-- | Configuration for compilation pass to add tick for instrumentation+-- to binding sites.+data TicksConfig = TicksConfig+  { ticks_passes       :: ![TickishType]+  -- ^ What purposes do we need ticks for++  , ticks_profAuto     :: !ProfAuto+  -- ^ What kind of {-# SCC #-} to add automatically++  , ticks_countEntries :: !Bool+  -- ^ Whether to count the entries to functions+  --+  -- Requires extra synchronization which can vastly degrade+  -- performance.+  }++data Tick = Tick+  { tick_loc   :: SrcSpan   -- ^ Tick source span+  , tick_path  :: [String]  -- ^ Path to the declaration+  , tick_ids   :: [OccName] -- ^ Identifiers being bound+  , tick_label :: BoxLabel  -- ^ Label for the tick counter+  }+++addTicksToBinds+        :: Logger+        -> TicksConfig+        -> Module+        -> ModLocation          -- ^ location of the current module+        -> NameSet              -- ^ Exported Ids.  When we call addTicksToBinds,+                                -- isExportedId doesn't work yet (the desugarer+                                -- hasn't set it), so we have to work from this set.+        -> [TyCon]              -- ^ Type constructors in this module+        -> LHsBinds GhcTc+        -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))++addTicksToBinds logger cfg+                mod mod_loc exports tyCons binds+  | let passes = ticks_passes cfg+  , not (null passes)+  , Just orig_file <- ml_hs_file mod_loc = do++     let  orig_file2 = guessSourceFile binds orig_file++          tickPass tickish (binds,st) =+            let env = TTE+                      { fileName     = mkFastString orig_file2+                      , declPath     = []+                      , tte_countEntries = ticks_countEntries cfg+                      , exports      = exports+                      , inlines      = emptyVarSet+                      , inScope      = emptyVarSet+                      , blackList    = Set.fromList $+                                       mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of+                                                             RealSrcSpan l _ -> Just l+                                                             UnhelpfulSpan _ -> Nothing)+                                                tyCons+                      , density      = mkDensity tickish $ ticks_profAuto cfg+                      , this_mod     = mod+                      , tickishType  = tickish+                      }+                (binds',_,st') = unTM (addTickLHsBinds binds) env st+            in (binds', st')++          (binds1,st) = foldr tickPass (binds, initTTState) passes++          extendedMixEntries = ticks st++     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell+       (pprLHsBinds binds1)++     return (binds1, Just (orig_file2, extendedMixEntries))++  | otherwise = return (binds, Nothing)++guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath+guessSourceFile binds orig_file =+     -- Try look for a file generated from a .hsc file to a+     -- .hs file, by peeking ahead.+     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->+                               srcSpanFileName_maybe (locA pos) : rest) [] binds+     in+     case top_pos of+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name+                      -> unpackFS file_name+        _ -> orig_file+++-- -----------------------------------------------------------------------------+-- TickDensity++-- | Where to insert ticks+data TickDensity+  = TickForCoverage       -- ^ for Hpc+  | TickForBreakPoints    -- ^ for GHCi+  | TickAllFunctions      -- ^ for -prof-auto-all+  | TickTopFunctions      -- ^ for -prof-auto-top+  | TickExportedFunctions -- ^ for -prof-auto-exported+  | TickCallSites         -- ^ for stack tracing+  deriving Eq++mkDensity :: TickishType -> ProfAuto -> TickDensity+mkDensity tickish pa = case tickish of+  HpcTicks             -> TickForCoverage+  SourceNotes          -> TickForCoverage+  Breakpoints          -> TickForBreakPoints+  ProfNotes ->+    case pa of+      ProfAutoAll      -> TickAllFunctions+      ProfAutoTop      -> TickTopFunctions+      ProfAutoExports  -> TickExportedFunctions+      ProfAutoCalls    -> TickCallSites+      _other           -> panic "mkDensity"++-- | Decide whether to add a tick to a binding or not.+shouldTickBind  :: TickDensity+                -> Bool         -- ^ top level?+                -> Bool         -- ^ exported?+                -> Bool         -- ^ simple pat bind?+                -> Bool         -- ^ INLINE pragma?+                -> Bool++shouldTickBind density top_lev exported _simple_pat inline+ = case density of+      TickForBreakPoints    -> False+        -- we never add breakpoints to simple pattern bindings+        -- (there's always a tick on the rhs anyway).+      TickAllFunctions      -> not inline+      TickTopFunctions      -> top_lev && not inline+      TickExportedFunctions -> exported && not inline+      TickForCoverage       -> True+      TickCallSites         -> False++shouldTickPatBind :: TickDensity -> Bool -> Bool+shouldTickPatBind density top_lev+  = case density of+      TickForBreakPoints    -> False+      TickAllFunctions      -> True+      TickTopFunctions      -> top_lev+      TickExportedFunctions -> False+      TickForCoverage       -> False+      TickCallSites         -> False++-- -----------------------------------------------------------------------------+-- Adding ticks to bindings++addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)+addTickLHsBinds = mapBagM addTickLHsBind++addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)+addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds+                                                 , abs_exports = abs_exports+                                                 }))) =+  withEnv add_exports $+    withEnv add_inlines $ do+      binds' <- addTickLHsBinds binds+      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }+  where+   -- in AbsBinds, the Id on each binding is not the actual top-level+   -- Id that we are defining, they are related by the abs_exports+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need+   -- to add the local Ids to the set of exported Names so that we know to+   -- tick the right bindings.+   add_exports env =+     env{ exports = exports env `extendNameSetList`+                      [ idName mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , idName pid `elemNameSet` (exports env) ] }++   -- See Note [inline sccs]+   add_inlines env =+     env{ inlines = inlines env `extendVarSetList`+                      [ mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , isInlinePragma (idInlinePragma pid) ] }++addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do+  let name = getOccString id+  decl_path <- getPathEntry+  density <- getDensity++  inline_ids <- liftM inlines getEnv+  -- See Note [inline sccs]+  let inline   = isInlinePragma (idInlinePragma id)+                 || id `elemVarSet` inline_ids++  -- See Note [inline sccs]+  tickish <- tickishType `liftM` getEnv+  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do++  (fvs, mg) <-+        getFreeVars $+        addPathEntry name $+        addTickMatchGroup False (fun_matches funBind)++  blackListed <- isBlackListed (locA pos)+  exported_names <- liftM exports getEnv++  -- We don't want to generate code for blacklisted positions+  -- We don't want redundant ticks on simple pattern bindings+  -- We don't want to tick non-exported bindings in TickExportedFunctions+  let simple = isSimplePatBind funBind+      toplev = null decl_path+      exported = idName id `elemNameSet` exported_names++  tick <- if not blackListed &&+               shouldTickBind density toplev exported simple inline+             then+                bindTick density name (locA pos) fvs+             else+                return Nothing++  let mbCons = maybe Prelude.id (:)+  return $ L pos $ funBind { fun_matches = mg+                           , fun_tick = tick `mbCons` fun_tick funBind }+  }++   where+   -- a binding is a simple pattern binding if it is a funbind with+   -- zero patterns+   isSimplePatBind :: HsBind GhcTc -> Bool+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0++-- TODO: Revisit this+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs+                                    , pat_rhs = rhs }))) = do++  let simplePatId = isSimplePat lhs++  -- TODO: better name for rhs's for non-simple patterns?+  let name = maybe "(...)" getOccString simplePatId++  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs+  let pat' = pat { pat_rhs = rhs'}++  -- Should create ticks here?+  density <- getDensity+  decl_path <- getPathEntry+  let top_lev = null decl_path+  if not (shouldTickPatBind density top_lev)+    then return (L pos pat')+    else do++    let mbCons = maybe id (:)++    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'++    -- Allocate the ticks++    rhs_tick <- bindTick density name (locA pos) fvs+    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks++    patvar_tickss <- case simplePatId of+      Just{} -> return initial_patvar_tickss+      Nothing -> do+        let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)+        patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars+        return+          (zipWith mbCons patvar_ticks+                          (initial_patvar_tickss ++ repeat []))++    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }++-- Only internal stuff, not from source, uses VarBind, so we ignore it.+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind++bindTick+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)+bindTick density name pos fvs = do+  decl_path <- getPathEntry+  let+      toplev        = null decl_path+      count_entries = toplev || density == TickAllFunctions+      top_only      = density /= TickAllFunctions+      box_label     = if toplev then TopLevelBox [name]+                                else LocalBox (decl_path ++ [name])+  --+  allocATickBox box_label count_entries top_only pos fvs+++-- Note [inline sccs]+-- ~~~~~~~~~~~~~~~~~~+-- The reason not to add ticks to INLINE functions is that this is+-- sometimes handy for avoiding adding a tick to a particular function+-- (see #6131)+--+-- So for now we do not add any ticks to INLINE functions at all.+--+-- We used to use isAnyInlinePragma to figure out whether to avoid adding+-- ticks for this purpose. However, #12962 indicates that this contradicts+-- the documentation on profiling (which only mentions INLINE pragmas).+-- So now we're more careful about what we avoid adding ticks to.++-- -----------------------------------------------------------------------------+-- Decorate an LHsExpr with ticks++-- selectively add ticks to interesting expressions+addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExpr e@(L pos e0) = do+  d <- getDensity+  case d of+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it+    TickForCoverage    -> tick_it+    TickCallSites      | isCallSite e0      -> tick_it+    _other             -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- Add a tick to an expression which is the RHS of an equation or a binding.+-- We always consider these to be breakpoints, unless the expression is a 'let'+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps+-- we should treat 'case' and 'if' the same way?+addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprRHS e@(L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     TickForCoverage -> tick_it+     TickCallSites   | isCallSite e0 -> tick_it+     _other          -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- The inner expression of an evaluation context:+--    let binds in [], ( [] )+-- we never tick these if we're doing HPC, but otherwise+-- we treat it like an ordinary expression.+addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprEvalInner e = do+   d <- getDensity+   case d of+     TickForCoverage -> addTickLHsExprNever e+     _otherwise      -> addTickLHsExpr e++-- | A let body is treated differently from addTickLHsExprEvalInner+-- above with TickForBreakPoints, because for breakpoints we always+-- want to tick the body, even if it is not a redex.  See test+-- break012.  This gives the user the opportunity to inspect the+-- values of the let-bound variables.+addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprLetBody e@(L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     _other -> addTickLHsExprEvalInner e+ where+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- version of addTick that does not actually add a tick,+-- because the scope of this tick is completely subsumed by+-- another.+addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprNever (L pos e0) = do+    e1 <- addTickHsExpr e0+    return $ L pos e1++-- General heuristic: expressions which are calls (do not denote+-- values) are good break points.+isGoodBreakExpr :: HsExpr GhcTc -> Bool+isGoodBreakExpr e = isCallSite e++isCallSite :: HsExpr GhcTc -> Bool+isCallSite HsApp{}     = True+isCallSite HsAppType{} = True+isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))+                       = isCallSite e+-- NB: OpApp, SectionL, SectionR are all expanded out+isCallSite _           = False++addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprOptAlt oneOfMany (L pos e0)+  = ifDensity TickForCoverage+        (allocTickBox (ExpBox oneOfMany) False False (locA pos)+          $ addTickHsExpr e0)+        (addTickLHsExpr (L pos e0))++addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addBinTickLHsExpr boxLabel (L pos e0)+  = ifDensity TickForCoverage+        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)+        (addTickLHsExpr (L pos e0))+++-- -----------------------------------------------------------------------------+-- Decorate the body of an HsExpr with ticks.+-- (Whether to put a tick around the whole expression was already decided,+-- in the addTickLHsExpr family of functions.)++addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)+addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e+addTickHsExpr e@(HsUnboundVar {})   = return e+addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e++addTickHsExpr e@(HsIPVar {})            = return e+addTickHsExpr e@(HsOverLit {})          = return e+addTickHsExpr e@(HsOverLabel{})         = return e+addTickHsExpr e@(HsLit {})              = return e+addTickHsExpr (HsLam x mg)              = liftM (HsLam x)+                                                (addTickMatchGroup True mg)+addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)+                                                   (addTickMatchGroup True mgs)+addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)+                                                          (addTickLHsExpr      e2)+addTickHsExpr (HsAppType x e at ty) = do+        e' <- addTickLHsExprNever e+        return (HsAppType x e' at ty)+addTickHsExpr (OpApp fix e1 e2 e3) =+        liftM4 OpApp+                (return fix)+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+                (addTickLHsExpr e3)+addTickHsExpr (NegApp x e neg) =+        liftM2 (NegApp x)+                (addTickLHsExpr e)+                (addTickSyntaxExpr hpcSrcSpan neg)+addTickHsExpr (HsPar x lpar e rpar) = do+        e' <- addTickLHsExprEvalInner e+        return (HsPar x lpar e' rpar)+addTickHsExpr (SectionL x e1 e2) =+        liftM2 (SectionL x)+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+addTickHsExpr (SectionR x e1 e2) =+        liftM2 (SectionR x)+                (addTickLHsExprNever e1)+                (addTickLHsExpr e2)+addTickHsExpr (ExplicitTuple x es boxity) =+        liftM2 (ExplicitTuple x)+                (mapM addTickTupArg es)+                (return boxity)+addTickHsExpr (ExplicitSum ty tag arity e) = do+        e' <- addTickLHsExpr e+        return (ExplicitSum ty tag arity e')+addTickHsExpr (HsCase x e mgs) =+        liftM2 (HsCase x)+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily+                                   -- be evaluated.+                (addTickMatchGroup False mgs)+addTickHsExpr (HsIf x e1 e2 e3) =+        liftM3 (HsIf x)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsExprOptAlt True e2)+                (addTickLHsExprOptAlt True e3)+addTickHsExpr (HsMultiIf ty alts)+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts+       ; return $ HsMultiIf ty alts' }+addTickHsExpr (HsLet x tkLet binds tkIn e) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          e' <- addTickLHsExprLetBody e+          return (HsLet x tkLet binds' tkIn e')+addTickHsExpr (HsDo srcloc cxt (L l stmts))+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())+       ; return (HsDo srcloc cxt (L l stmts')) }+  where+        forQual = case cxt of+                    ListComp -> Just $ BinBox QualBinBox+                    _        -> Nothing+addTickHsExpr (ExplicitList ty es)+  = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)++addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e++addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })+  = do { rec_binds' <- addTickHsRecordBinds rec_binds+       ; return (expr { rcon_flds = rec_binds' }) }++addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) }+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) }++addTickHsExpr (ExprWithTySig x e ty) =+        liftM3 ExprWithTySig+                (return x)+                (addTickLHsExprNever e) -- No need to tick the inner expression+                                        -- for expressions with signatures+                (return ty)+addTickHsExpr (ArithSeq ty wit arith_seq) =+        liftM3 ArithSeq+                (return ty)+                (addTickWit wit)+                (addTickArithSeqInfo arith_seq)+             where addTickWit Nothing = return Nothing+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl+                                             return (Just fl')++addTickHsExpr (HsPragE x p e) =+        liftM (HsPragE x p) (addTickLHsExpr e)+addTickHsExpr e@(HsTypedBracket {})  = return e+addTickHsExpr e@(HsUntypedBracket{}) = return e+addTickHsExpr e@(HsTypedSplice{})    = return e+addTickHsExpr e@(HsUntypedSplice{})  = return e+addTickHsExpr e@(HsGetField {})      = return e+addTickHsExpr e@(HsProjection {})    = return e+addTickHsExpr (HsProc x pat cmdtop) =+        liftM2 (HsProc x)+                (addTickLPat pat)+                (liftL (addTickHsCmdTop) cmdtop)+addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =+        liftM (XExpr . WrapExpr . HsWrap w) $+              (addTickHsExpr e)        -- Explicitly no tick on inside+addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =+        liftM (XExpr . ExpansionExpr . HsExpanded a) $+              (addTickHsExpr b)++addTickHsExpr e@(XExpr (ConLikeTc {})) = return e+  -- We used to do a freeVar on a pat-syn builder, but actually+  -- such builders are never in the inScope env, which+  -- doesn't include top level bindings++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (XExpr (HsTick t e)) =+        liftM (XExpr . HsTick t) (addTickLHsExprNever e)+addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =+        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)++addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)+addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e+                                  ; return (Present x e') }+addTickTupArg (Missing ty) = return (Missing ty)+++addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)+                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do+  let isOneOfMany = matchesOneOfMany matches+  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches+  return $ mg { mg_alts = L l matches' }++addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)+             -> TM (Match GhcTc (LHsExpr GhcTc))+addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats+                                               , m_grhss = gRHSs }) =+  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do+    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs+    return $ match { m_grhss = gRHSs' }++addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)+             -> TM (GRHSs GhcTc (LHsExpr GhcTc))+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =+  bindLocals binders $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded+    return $ GRHSs x guarded' local_binds'+  where+    binders = collectLocalBinders CollNoDictBinders local_binds++addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)+            -> TM (GRHS GhcTc (LHsExpr GhcTc))+addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do+  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts+                        (addTickGRHSBody isOneOfMany isLambda expr)+  return $ GRHS x stmts' expr'++addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do+  d <- getDensity+  case d of+    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr+    TickAllFunctions | isLambda ->+       addPathEntry "\\" $+         allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $+           addTickHsExpr e0+    _otherwise ->+       addTickLHsExprRHS expr++addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]+              -> TM [ExprLStmt GhcTc]+addTickLStmts isGuard stmts = do+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())+  return stmts++addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a+               -> TM ([ExprLStmt GhcTc], a)+addTickLStmts' isGuard lstmts res+  = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts+       ; a <- res+       ; return (lstmts', a) }++addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)+            -> TM (Stmt GhcTc (LHsExpr GhcTc))+addTickStmt _isGuard (LastStmt x e noret ret) =+        liftM3 (LastStmt x)+                (addTickLHsExpr e)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickStmt _isGuard (BindStmt xbs pat e) =+        liftM4 (\b f -> BindStmt $ XBindStmtTc+                    { xbstc_bindOp = b+                    , xbstc_boundResultType = xbstc_boundResultType xbs+                    , xbstc_boundResultMult = xbstc_boundResultMult xbs+                    , xbstc_failOp = f+                    })+                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))+                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))+                (addTickLPat pat)+                (addTickLHsExprRHS e)+addTickStmt isGuard (BodyStmt x e bind' guard') =+        liftM3 (BodyStmt x)+                (addTick isGuard e)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+addTickStmt _isGuard (LetStmt x binds) =+        liftM (LetStmt x)+                (addTickHsLocalBinds binds)+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =+    liftM3 (ParStmt x)+        (mapM (addTickStmtAndBinders isGuard) pairs)+        (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))+        (addTickSyntaxExpr hpcSrcSpan bindExpr)+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do+    args' <- mapM (addTickApplicativeArg isGuard) args+    return (ApplicativeStmt body_ty args' mb_join)++addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts+                                    , trS_by = by, trS_using = using+                                    , trS_ret = returnExpr, trS_bind = bindExpr+                                    , trS_fmap = liftMExpr }) = do+    t_s <- addTickLStmts isGuard stmts+    t_y <- fmapMaybeM  addTickLHsExprRHS by+    t_u <- addTickLHsExprRHS using+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr+    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }++addTickStmt isGuard stmt@(RecStmt {})+  = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }++addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e+                  | otherwise          = addTickLHsExprRHS e++addTickApplicativeArg+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)+addTickApplicativeArg isGuard (op, arg) =+  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)+ where+  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =+    ApplicativeArgOne+      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail+      <*> addTickLPat pat+      <*> addTickLHsExpr expr+      <*> pure isBody+  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =+    (ApplicativeArgMany x)+      <$> addTickLStmts isGuard stmts+      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))+      <*> addTickLPat pat+      <*> pure ctxt++addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc+                      -> TM (ParStmtBlock GhcTc GhcTc)+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =+    liftM3 (ParStmtBlock x)+        (addTickLStmts isGuard stmts)+        (return ids)+        (addTickSyntaxExpr hpcSrcSpan returnExpr)++addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)+addTickHsLocalBinds (HsValBinds x binds) =+        liftM (HsValBinds x)+                (addTickHsValBinds binds)+addTickHsLocalBinds (HsIPBinds x binds)  =+        liftM (HsIPBinds x)+                (addTickHsIPBinds binds)+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)++addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)+                  -> TM (HsValBindsLR GhcTc (GhcPass b))+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do+        b <- liftM2 NValBinds+                (mapM (\ (rec,binds') ->+                                liftM2 (,)+                                        (return rec)+                                        (addTickLHsBinds binds'))+                        binds)+                (return sigs)+        return $ XValBindsLR b+addTickHsValBinds _ = panic "addTickHsValBinds"++addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)+addTickHsIPBinds (IPBinds dictbinds ipbinds) =+        liftM2 IPBinds+                (return dictbinds)+                (mapM (liftL (addTickIPBind)) ipbinds)++addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)+addTickIPBind (IPBind x nm e) =+        liftM (IPBind x nm)+               (addTickLHsExpr e)++-- There is no location here, so we might need to use a context location??+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)+addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do+        x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))+        return $ syn { syn_expr = x' }+addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc++-- we do not walk into patterns.+addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)+addTickLPat pat = return pat++addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)+addTickHsCmdTop (HsCmdTop x cmd) =+        liftM2 HsCmdTop+                (return x)+                (addTickLHsCmd cmd)++addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)+addTickLHsCmd (L pos c0) = do+        c1 <- addTickHsCmd c0+        return $ L pos c1++addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)+addTickHsCmd (HsCmdLam x matchgroup) =+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)+addTickHsCmd (HsCmdApp x c e) =+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)+{-+addTickHsCmd (OpApp e1 c2 fix c3) =+        liftM4 OpApp+                (addTickLHsExpr e1)+                (addTickLHsCmd c2)+                (return fix)+                (addTickLHsCmd c3)+-}+addTickHsCmd (HsCmdPar x lpar e rpar) = do+        e' <- addTickLHsCmd e+        return (HsCmdPar x lpar e' rpar)+addTickHsCmd (HsCmdCase x e mgs) =+        liftM2 (HsCmdCase x)+                (addTickLHsExpr e)+                (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdLamCase x lc_variant mgs) =+        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =+        liftM3 (HsCmdIf x cnd)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsCmd c2)+                (addTickLHsCmd c3)+addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do+          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.+          c' <- addTickLHsCmd c+          return (HsCmdLet x tkLet binds' tkIn c')+addTickHsCmd (HsCmdDo srcloc (L l stmts))+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())+       ; return (HsCmdDo srcloc (L l stmts')) }++addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =+        liftM5 HsCmdArrApp+               (return arr_ty)+               (addTickLHsExpr e1)+               (addTickLHsExpr e2)+               (return ty1)+               (return lr)+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =+        liftM4 (HsCmdArrForm x)+               (addTickLHsExpr e)+               (return f)+               (return fix)+               (mapM (liftL (addTickHsCmdTop)) cmdtop)++addTickHsCmd (XCmd (HsWrap w cmd)) =+  liftM XCmd $+  liftM (HsWrap w) (addTickHsCmd cmd)++-- Others should never happen in a command context.+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)++addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)+                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))+addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do+  matches' <- mapM (liftL addTickCmdMatch) matches+  return $ mg { mg_alts = L l matches' }++addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))+addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =+  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do+    gRHSs' <- addTickCmdGRHSs gRHSs+    return $ match { m_grhss = gRHSs' }++addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))+addTickCmdGRHSs (GRHSs x guarded local_binds) =+  bindLocals binders $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (liftL addTickCmdGRHS) guarded+    return $ GRHSs x guarded' local_binds'+  where+    binders = collectLocalBinders CollNoDictBinders local_binds++addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))+-- The *guards* are *not* Cmds, although the body is+-- C.f. addTickGRHS for the BinBox stuff+addTickCmdGRHS (GRHS x stmts cmd)+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)+                                   stmts (addTickLHsCmd cmd)+       ; return $ GRHS x stmts' expr' }++addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]+                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]+addTickLCmdStmts stmts = do+  (stmts, _) <- addTickLCmdStmts' stmts (return ())+  return stmts++addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a+                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)+addTickLCmdStmts' lstmts res+  = bindLocals binders $ do+        lstmts' <- mapM (liftL addTickCmdStmt) lstmts+        a <- res+        return (lstmts', a)+  where+        binders = collectLStmtsBinders CollNoDictBinders lstmts++addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))+addTickCmdStmt (BindStmt x pat c) =+        liftM2 (BindStmt x)+                (addTickLPat pat)+                (addTickLHsCmd c)+addTickCmdStmt (LastStmt x c noret ret) =+        liftM3 (LastStmt x)+                (addTickLHsCmd c)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickCmdStmt (BodyStmt x c bind' guard') =+        liftM3 (BodyStmt x)+                (addTickLHsCmd c)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+addTickCmdStmt (LetStmt x binds) =+        liftM (LetStmt x)+                (addTickHsLocalBinds binds)+addTickCmdStmt stmt@(RecStmt {})+  = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }+addTickCmdStmt ApplicativeStmt{} =+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"++-- Others should never happen in a command context.+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)++addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)+addTickHsRecordBinds (HsRecFields fields dd)+  = do  { fields' <- mapM addTickHsRecField fields+        ; return (HsRecFields fields' dd) }++addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)+                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))+addTickHsRecField (L l (HsFieldBind x id expr pun))+        = do { expr' <- addTickLHsExpr expr+             ; return (L l (HsFieldBind x id expr' pun)) }++addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)+addTickArithSeqInfo (From e1) =+        liftM From+                (addTickLHsExpr e1)+addTickArithSeqInfo (FromThen e1 e2) =+        liftM2 FromThen+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromTo e1 e2) =+        liftM2 FromTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromThenTo e1 e2 e3) =+        liftM3 FromThenTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+                (addTickLHsExpr e3)++data TickTransState = TT { ticks       :: !(SizedSeq Tick)+                         , ccIndices   :: !CostCentreState+                         }++initTTState :: TickTransState+initTTState = TT { ticks        = emptySS+                 , ccIndices    = newCostCentreState+                 }++addMixEntry :: Tick -> TM Int+addMixEntry ent = do+  c <- fromIntegral . sizeSS . ticks <$> getState+  setState $ \st ->+    st { ticks = addToSS (ticks st) ent+       }+  return c++data TickTransEnv = TTE { fileName     :: FastString+                        , density      :: TickDensity+                        , tte_countEntries :: !Bool+                          -- ^ Whether the number of times functions are+                          -- entered should be counted.+                        , exports      :: NameSet+                        , inlines      :: VarSet+                        , declPath     :: [String]+                        , inScope      :: VarSet+                        , blackList    :: Set RealSrcSpan+                        , this_mod     :: Module+                        , tickishType  :: TickishType+                        }++--      deriving Show++-- | Reasons why we need ticks,+data TickishType+  -- | For profiling+  = ProfNotes+  -- | For Haskell Program Coverage+  | HpcTicks+  -- | For ByteCode interpreter break points+  | Breakpoints+  -- | For source notes+  | SourceNotes+  deriving (Eq)++-- | Tickishs that only make sense when their source code location+-- refers to the current file. This might not always be true due to+-- LINE pragmas in the code - which would confuse at least HPC.+tickSameFileOnly :: TickishType -> Bool+tickSameFileOnly HpcTicks = True+tickSameFileOnly _other   = False++type FreeVars = OccEnv Id+noFVs :: FreeVars+noFVs = emptyOccEnv++-- Note [freevars]+-- ~~~~~~~~~~~~~~~+--   For breakpoints we want to collect the free variables of an+--   expression for pinning on the HsTick.  We don't want to collect+--   *all* free variables though: in particular there's no point pinning+--   on free variables that are will otherwise be in scope at the GHCi+--   prompt, which means all top-level bindings.  Unfortunately detecting+--   top-level bindings isn't easy (collectHsBindsBinders on the top-level+--   bindings doesn't do it), so we keep track of a set of "in-scope"+--   variables in addition to the free variables, and the former is used+--   to filter additions to the latter.  This gives us complete control+--   over what free variables we track.++newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+    deriving (Functor)+        -- a combination of a state monad (TickTransState) and a writer+        -- monad (FreeVars).++instance Applicative TM where+    pure a = TM $ \ _env st -> (a,noFVs,st)+    (<*>) = ap++instance Monad TM where+  (TM m) >>= k = TM $ \ env st ->+                                case m env st of+                                  (r1,fv1,st1) ->+                                     case unTM (k r1) env st1 of+                                       (r2,fv2,st2) ->+                                          (r2, fv1 `plusOccEnv` fv2, st2)++-- | Get the next HPC cost centre index for a given centre name+getCCIndexM :: FastString -> TM CostCentreIndex+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $+                                                 ccIndices st+                              in (idx, noFVs, st { ccIndices = is' })++getState :: TM TickTransState+getState = TM $ \ _ st -> (st, noFVs, st)++setState :: (TickTransState -> TickTransState) -> TM ()+setState f = TM $ \ _ st -> ((), noFVs, f st)++getEnv :: TM TickTransEnv+getEnv = TM $ \ env st -> (env, noFVs, st)++withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a+withEnv f (TM m) = TM $ \ env st ->+                                 case m (f env) st of+                                   (a, fvs, st') -> (a, fvs, st')++getDensity :: TM TickDensity+getDensity = TM $ \env st -> (density env, noFVs, st)++ifDensity :: TickDensity -> TM a -> TM a -> TM a+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el++getFreeVars :: TM a -> TM (FreeVars, a)+getFreeVars (TM m)+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')++freeVar :: Id -> TM ()+freeVar id = TM $ \ env st ->+                if id `elemVarSet` inScope env+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)+                   else ((), noFVs, st)++addPathEntry :: String -> TM a -> TM a+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })++getPathEntry :: TM [String]+getPathEntry = declPath `liftM` getEnv++getFileName :: TM FastString+getFileName = fileName `liftM` getEnv++isGoodSrcSpan' :: SrcSpan -> Bool+isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos+isGoodSrcSpan' (UnhelpfulSpan _) = False++isGoodTickSrcSpan :: SrcSpan -> TM Bool+isGoodTickSrcSpan pos = do+  file_name <- getFileName+  tickish <- tickishType `liftM` getEnv+  let need_same_file = tickSameFileOnly tickish+      same_file      = Just file_name == srcSpanFileName_maybe pos+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))++ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a+ifGoodTickSrcSpan pos then_code else_code = do+  good <- isGoodTickSrcSpan pos+  if good then then_code else else_code++bindLocals :: [Id] -> TM a -> TM a+bindLocals new_ids (TM m)+  = TM $ \ env st ->+                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')+  where occs = [ nameOccName (idName id) | id <- new_ids ]++isBlackListed :: SrcSpan -> TM Bool+isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)+isBlackListed (UnhelpfulSpan _) = return False++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)+             -> TM (LHsExpr GhcTc)+allocTickBox boxLabel countEntries topOnly pos m =+  ifGoodTickSrcSpan pos (do+    (fvs, e) <- getFreeVars m+    env <- getEnv+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)+    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))+  ) (do+    e <- m+    return (L (noAnnSrcSpan pos) e)+  )++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars+              -> TM (Maybe CoreTickish)+allocATickBox boxLabel countEntries topOnly  pos fvs =+  ifGoodTickSrcSpan pos (do+    let+      mydecl_path = case boxLabel of+                      TopLevelBox x -> x+                      LocalBox xs  -> xs+                      _ -> panic "allocATickBox"+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path+    return (Just tickish)+  ) (return Nothing)+++mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]+          -> TM CoreTickish+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do++  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs+          -- unlifted types cause two problems here:+          --   * we can't bind them  at the GHCi prompt+          --     (bindLocalsAtBreakpoint already filters them out),+          --   * the simplifier might try to substitute a literal for+          --     the Id, and we can't handle that.++      me = Tick+        { tick_loc   = pos+        , tick_path  = decl_path+        , tick_ids   = map (nameOccName.idName) ids+        , tick_label = boxLabel+        }++      cc_name | topOnly   = head decl_path+              | otherwise = concat (intersperse "." decl_path)++  env <- getEnv+  case tickishType env of+    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me++    ProfNotes -> do+      let nm = mkFastString cc_name+      flavour <- HpcCC <$> getCCIndexM nm+      let cc = mkUserCC nm (this_mod env) pos flavour+          count = countEntries && tte_countEntries env+      return $ ProfNote cc count True{-scopes-}++    Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids++    SourceNotes | RealSrcSpan pos' _ <- pos ->+      return $ SourceNote pos' cc_name++    _otherwise -> panic "mkTickish: bad source span!"+++allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)+                -> TM (LHsExpr GhcTc)+allocBinTickBox boxLabel pos m = do+  env <- getEnv+  case tickishType env of+    HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m+                   ifGoodTickSrcSpan pos+                     (mkBinTickBoxHpc boxLabel pos e)+                     (return e)+    _other   -> allocTickBox (ExpBox False) False False pos m++mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc+                -> TM (LHsExpr GhcTc)+mkBinTickBoxHpc boxLabel pos e = do+  env <- getEnv+  binTick <- HsBinTick+    <$> addMixEntry (Tick { tick_loc = pos+                          , tick_path = declPath env+                          , tick_ids = []+                          , tick_label = boxLabel True+                          })+    <*> addMixEntry (Tick { tick_loc = pos+                          , tick_path = declPath env+                          , tick_ids = []+                          , tick_label = boxLabel False+                          })+    <*> pure e+  tick <- HpcTick (this_mod env)+    <$> addMixEntry (Tick { tick_loc = pos+                          , tick_path = declPath env+                          , tick_ids = []+                          , tick_label = ExpBox False+                          })+  let pos' = noAnnSrcSpan pos+  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))++hpcSrcSpan :: SrcSpan+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")++matchesOneOfMany :: [LMatch GhcTc body] -> Bool+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1+  where+        matchCount :: LMatch GhcTc body -> Int+        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))+          = length grhss
compiler/GHC/HsToCore/Utils.hs view
@@ -142,7 +142,7 @@                                   -- multiplicity stored within the variable                                   -- itself. It's easier to pull it from the                                   -- variable, so we ignore the multiplicity.-selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var))+selectMatchVar _w (AsPat _ var _ _) = assert (isManyDataConTy _w ) (return (unLoc var)) selectMatchVar w other_pat        = newSysLocalDs w (hsPatType other_pat)  {- Note [Localise pattern binders]
compiler/GHC/Iface/Env.hs view
@@ -6,7 +6,7 @@         newGlobalBinder, newInteractiveBinder,         externaliseName,         lookupIfaceTop,-        lookupOrig, lookupOrigIO, lookupOrigNameCache,+        lookupOrig, lookupNameCache, lookupOrigNameCache,         newIfaceName, newIfaceNames,         extendIfaceIdEnv, extendIfaceTyVarEnv,         tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,@@ -145,10 +145,6 @@   hsc_env <- getTopEnv   traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)   liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ--lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name-lookupOrigIO hsc_env mod occ-  = lookupNameCache (hsc_NC hsc_env) mod occ  lookupNameCache :: NameCache -> Module -> OccName -> IO Name -- Lookup up the (Module,OccName) in the NameCache
compiler/GHC/Iface/Ext/Ast.hs view
@@ -377,8 +377,9 @@      let asts = HieASTs $ resolveTyVarScopes asts'     return asts-  where-    processGrp grp = concatM++processGrp :: HsGroup GhcRn -> HieM [HieAST Type]+processGrp grp = concatM       [ toHie $ fmap (RS ModuleScope ) hs_valds grp       , toHie $ hs_splcds grp       , toHie $ hs_tyclds grp@@ -495,15 +496,15 @@   map (\(RS sc a) -> PS rsp useScope sc a) $     listScopes patScope xs --- | 'listScopes' specialised to 'HsPatSigType'-tScopes+-- | 'listScopes' specialised to 'HsConPatTyArg'+taScopes   :: Scope   -> Scope-  -> [HsPatSigType (GhcPass a)]+  -> [HsConPatTyArg (GhcPass a)]   -> [TScoped (HsPatSigType (GhcPass a))]-tScopes scope rhsScope xs =+taScopes scope rhsScope xs =   map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $-    listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs)+    listScopes rhsScope (map (\(HsConPatTyArg _ hsps) -> L (getLoc $ hsps_body hsps) hsps) xs)   -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.   -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS. @@ -798,7 +799,7 @@       , Data (AmbiguousFieldOcc (GhcPass p))       , Data (HsCmdTop (GhcPass p))       , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))-      , Data (HsSplice (GhcPass p))+      , Data (HsUntypedSplice (GhcPass p))       , Data (HsLocalBinds (GhcPass p))       , Data (FieldOcc (GhcPass p))       , Data (HsTupArg (GhcPass p))@@ -963,7 +964,7 @@       LazyPat _ p ->         [ toHie $ PS rsp scope pscope p         ]-      AsPat _ lname pat ->+      AsPat _ lname _ pat ->         [ toHie $ C (PatternBind scope                                  (combineScopes (mkLScopeA pat) pscope)                                  rsp)@@ -1038,9 +1039,11 @@               ]             ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]     where-      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a)+      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsConPatTyArg GhcRn) a (HsRecFields (GhcPass p) a)                  -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))-      contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)+      contextify (PrefixCon tyargs args) =+        PrefixCon (taScopes scope argscope tyargs)+                  (patScopes rsp scope pscope args)         where argscope = foldr combineScopes NoScope $ map mkLScopeA args       contextify (InfixCon a b) = InfixCon a' b'         where [a', b'] = patScopes rsp scope pscope [a,b]@@ -1104,7 +1107,7 @@         [ toHie a         , toHie b         ]-      HsAppType _ expr sig ->+      HsAppType _ expr _ sig ->         [ toHie expr         , toHie $ TS (ResolvedScopes []) sig         ]@@ -1202,11 +1205,14 @@             [ toHie b             , toHie xbracket             ]-        HieTc | HsBracketTc _ _ _ p <- xbracket ->-          [ toHie b+        HieTc | HsBracketTc q _ _ p <- xbracket ->+          [ toHie q           , toHie p           ]-      HsSpliceE _ x ->+      HsTypedSplice _ x ->+        [ toHie x+        ]+      HsUntypedSplice _ x ->         [ toHie $ L mspan x         ]       HsGetField {} -> []@@ -1871,14 +1877,19 @@         [ toHie splice         ] -instance ToHie (HsQuote a) where-  toHie _ = pure []+instance ToHie (HsQuote GhcRn) where+  toHie (ExpBr _ e)  = toHie e+  toHie (PatBr _ b)  = toHie (PS Nothing NoScope NoScope b)+  toHie (DecBrL {} ) = pure []+  toHie (DecBrG _ decls) = processGrp decls+  toHie (TypBr _ ty) = toHie ty+  toHie (VarBr {} )  = pure []  instance ToHie PendingRnSplice where-  toHie _ = pure []+  toHie (PendingRnSplice _ _ e) = toHie e  instance ToHie PendingTcSplice where-  toHie _ = pure []+  toHie (PendingTcSplice _ e) = toHie e  instance ToHie (LBooleanFormula (LocatedN Name)) where   toHie (L span form) = concatM $ makeNode form (locA span) : case form of@@ -1898,25 +1909,14 @@ instance ToHie (LocatedAn NoEpAnns HsIPName) where   toHie (L span e) = makeNodeA e span -instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where+instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where   toHie (L span sp) = concatM $ makeNodeA sp span : case sp of-      HsTypedSplice _ _ _ expr ->-        [ toHie expr-        ]-      HsUntypedSplice _ _ _ expr ->+      HsUntypedSpliceExpr _ expr ->         [ toHie expr         ]-      HsQuasiQuote _ _ _ ispan _ ->-        [ locOnly ispan+      HsQuasiQuote _ _ ispanFs ->+        [ locOnly (getLocA ispanFs)         ]-      HsSpliced _ _ _ ->-        []-      XSplice x -> case hiePass @p of-#if __GLASGOW_HASKELL__ < 811-                     HieRn -> dataConCantHappen x-#endif-                     HieTc -> case x of-                                HsSplicedT _ -> []  instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where   toHie (L span annot) = concatM $ makeNodeA annot span : case annot of
compiler/GHC/Iface/Tidy.hs view
@@ -1291,7 +1291,7 @@       = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs       | otherwise       = minimal_unfold_info-    minimal_unfold_info = zapUnfolding unf_info+    minimal_unfold_info = trimUnfolding unf_info     unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs     -- NB: do *not* expose the worker if show_unfold is off,     --     because that means this thing is a loop breaker or
compiler/GHC/IfaceToCore.hs view
@@ -29,6 +29,7 @@  import GHC.Driver.Env import GHC.Driver.Session+import GHC.Driver.Config.Core.Lint ( initLintConfig )  import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Builtin.Types@@ -94,6 +95,7 @@ import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Unique.DSet ( mkUniqDSet )+import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import GHC.Types.Unique.Supply import GHC.Types.Literal import GHC.Types.Var as Var@@ -1224,7 +1226,7 @@                                         (nonDetEltsUFM $ if_id_env lcl_env) ++                                         bndrs' ++                                         exprsFreeIdsList args')-                      ; case lintExpr dflags in_scope rhs' of+                      ; case lintExpr (initLintConfig dflags in_scope) rhs' of                           Nothing   -> return ()                           Just errs -> do                             logger <- getLogger@@ -1619,7 +1621,7 @@  tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _  IfVanillaId = return VanillaId-tcIdDetails _  (IfStrictWorkerId dmds) = return $ StrictWorkerId dmds+tcIdDetails _  (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds tcIdDetails ty IfDFunId   = return (DFunId (isNewTyCon (classTyCon cls)))   where@@ -1780,10 +1782,10 @@     -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint     when (isTopLevel toplvl) $       whenGOptM Opt_DoCoreLinting $ do-        in_scope <- get_in_scope+        in_scope <- nonDetEltsUniqSet <$> get_in_scope         dflags   <- getDynFlags         logger   <- getLogger-        case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of+        case lintUnfolding is_compulsory (initLintConfig dflags in_scope) noSrcLoc core_expr' of           Nothing   -> return ()           Just errs -> liftIO $             displayLintResults logger False doc
compiler/GHC/Plugins.hs view
@@ -63,6 +63,7 @@    , module GHC.Hs    , -- * Getting 'Name's      thNameToGhcName+   , thNameToGhcNameIO    ) where @@ -135,11 +136,12 @@ import GHC.Data.FastString import Data.Maybe -import GHC.Iface.Env    ( lookupOrigIO )+import GHC.Iface.Env    ( lookupNameCache ) import GHC.Prelude import GHC.Utils.Monad  ( mapMaybeM ) import GHC.ThToHs       ( thRdrNameGuesses ) import GHC.Tc.Utils.Env ( lookupGlobal )+import GHC.Types.Name.Cache ( NameCache )  import GHC.Tc.Errors.Hole.FitTypes @@ -171,7 +173,29 @@ -- to names in the module being compiled, if possible. Exact TH names -- will be bound to the name they represent, exactly. thNameToGhcName :: TH.Name -> CoreM (Maybe Name)-thNameToGhcName th_name+thNameToGhcName th_name = do+  hsc_env <- getHscEnv+  liftIO $ thNameToGhcNameIO (hsc_NC hsc_env) th_name++-- | Attempt to convert a Template Haskell name to one that GHC can+-- understand. Original TH names such as those you get when you use+-- the @'foo@ syntax will be translated to their equivalent GHC name+-- exactly. Qualified or unqualified TH names will be dynamically bound+-- to names in the module being compiled, if possible. Exact TH names+-- will be bound to the name they represent, exactly.+--+-- One must be careful to consistently use the same 'NameCache' to+-- create identifier that might be compared. (C.f. how the+-- 'Control.Monad.ST.ST' Monad enforces that variables from separate+-- 'Control.Monad.ST.runST' invocations are never intermingled; it would+-- be valid to use the same tricks for 'Name's and 'NameCache's.)+--+-- For now, the easiest and recommended way to ensure a consistent+-- 'NameCache' is used it to retrieve the preexisting one from an active+-- 'HscEnv'. A single 'HscEnv' is created per GHC "session", and this+-- ensures everything in that sesssion will getthe same name cache.+thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name)+thNameToGhcNameIO cache th_name   =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)           -- Pick the first that works           -- E.g. reify (mkName "A") will pick the class A in preference@@ -182,6 +206,5 @@       | Just n <- isExact_maybe rdr_name   -- This happens in derived code       = return $ if isExternalName n then Just n else Nothing       | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name-      = do { hsc_env <- getHscEnv-           ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) }+      = Just <$> lookupNameCache cache rdr_mod rdr_occ       | otherwise = return Nothing
compiler/GHC/Rename/Env.hs view
@@ -77,7 +77,7 @@ import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Warnings  ( WarningTxt, pprWarningTxtForMsg )+import GHC.Unit.Module.Warnings  ( WarningTxt ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon@@ -275,7 +275,7 @@           let occ = rdrNameOcc rdr_name         ; when (isTcOcc occ && isSymOcc occ)                (do { op_ok <- xoptM LangExt.TypeOperators-                   ; unless op_ok (addErr (opDeclErr rdr_name)) })+                   ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) })          ; env <- getGlobalRdrEnv         ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of@@ -1111,10 +1111,10 @@  badVarInType :: RdrName -> RnM Name badVarInType rdr_name-  = do { addErr (TcRnUnknownMessage $ mkPlainError noHints-           (text "Illegal promoted term variable in a type:"-                 <+> ppr rdr_name))-       ; return (mkUnboundNameRdr rdr_name) }+  = do { addErr (TcRnUnpromotableThing name TermVariablePE)+       ; return name }+      where+        name = mkUnboundNameRdr rdr_name  {- Note [Promoted variables in types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1553,34 +1553,22 @@                    -- See Note [Handling of deprecations]          do { iface <- loadInterfaceForName doc name             ; case lookupImpDeprec iface gre of-                Just txt -> do-                  let msg = TcRnUnknownMessage $-                              mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)-                                                noHints-                                                (mk_msg imp_spec txt)--                  addDiagnostic msg+                Just deprText -> addDiagnostic $+                  TcRnPragmaWarning {+                    pragma_warning_occ = occ,+                    pragma_warning_msg = deprText,+                    pragma_warning_import_mod = importSpecModule imp_spec,+                    pragma_warning_defined_mod = definedMod+                  }                 Nothing  -> return () } }   | otherwise   = return ()   where     occ = greOccName gre     name = greMangledName gre-    name_mod = assertPpr (isExternalName name) (ppr name) (nameModule name)+    definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name)     doc = text "The name" <+> quotes (ppr occ) <+> text "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 GhcRn) lookupImpDeprec iface gre   = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,@@ -2093,25 +2081,9 @@  -- Error messages -opDeclErr :: RdrName -> TcRnMessage-opDeclErr n-  = TcRnUnknownMessage $ mkPlainError noHints $-    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 -> TcRnMessage badOrigBinding name-  | Just _ <- isBuiltInOcc_maybe occ-  = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal binding of built-in syntax:" <+> ppr occ-    -- Use an OccName here because we don't want to print Prelude.(,)-  | otherwise-  = TcRnUnknownMessage $ mkPlainError noHints $-    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.)+  | Just _ <- isBuiltInOcc_maybe occ = TcRnIllegalBindingOfBuiltIn occ+  | otherwise = TcRnNameByTemplateHaskellQuote name   where     occ = rdrNameOcc $ filterCTuple name
compiler/GHC/Rename/Expr.hs view
@@ -47,7 +47,7 @@                         , genHsVar, genLHsVar, genHsApp, genHsApps                         , genAppType ) import GHC.Rename.Unbound ( reportUnboundName )-import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName )+import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName ) import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session@@ -122,7 +122,7 @@ * HsIf (if-the-else)      if b then e1 else e2  ==>  ifThenElse b e1 e2   We do this /only/ if rebindable syntax is on, because the coverage-  checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr)+  checker looks for HsIf (see GHC.HsToCore.Ticks.addTickHsExpr)   That means the typechecker and desugarer need to understand HsIf   for the non-rebindable-syntax case. @@ -283,7 +283,7 @@ rnExpr (HsOverLabel _ v)   = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName        ; return ( mkExpandedExpr (HsOverLabel noAnn v) $-                  HsAppType noExtField (genLHsVar from_label) hs_ty_arg+                  HsAppType noExtField (genLHsVar from_label) noHsTok hs_ty_arg                 , fvs ) }   where     hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $@@ -314,12 +314,12 @@        ; (arg',fvArg) <- rnLExpr arg        ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType _ fun arg)+rnExpr (HsAppType _ fun at 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 NoExtField fun' arg', fvFun `plusFV` fvArg) }+       ; return (HsAppType NoExtField fun' at arg', fvFun `plusFV` fvArg) }  rnExpr (OpApp _ e1 op e2)   = do  { (e1', fv_e1) <- rnLExpr e1@@ -375,7 +375,8 @@ rnExpr e@(HsTypedBracket _ br_body)   = rnTypedBracket e br_body rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body -rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice+rnExpr (HsTypedSplice   _ splice) = rnTypedSplice splice+rnExpr (HsUntypedSplice _ splice) = rnUntypedSpliceExpr splice  --------------------------------------------- --      Sections@@ -2249,7 +2250,7 @@     WildPat{}       -> False     VarPat{}        -> False     LazyPat{}       -> False-    AsPat _ _ p     -> isStrictPattern p+    AsPat _ _ _ p   -> isStrictPattern p     ParPat _ _ p _  -> isStrictPattern p     ViewPat _ _ p   -> isStrictPattern p     SigPat _ p _    -> isStrictPattern p@@ -2422,7 +2423,7 @@   _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 _ (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
compiler/GHC/Rename/Module.hs view
@@ -1325,7 +1325,7 @@     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 (HsAppType _ e _ _)             = checkl e     check (HsVar _ lv)       | (unLoc lv) `notElem` foralls      = Nothing     check other                           = Just other  -- Failure@@ -2545,8 +2545,8 @@   = 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+           DollarSplice -> return ()+           BareSplice -> do { th_on <- xoptM LangExt.TemplateHaskell                                 ; unless th_on $ setSrcSpan (locA loc) $                                   failWith badImplicitSplice }
compiler/GHC/Rename/Pat.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeApplications    #-} {-# LANGUAGE DeriveFunctor       #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE RankNTypes          #-}@@ -22,7 +22,7 @@ free variables. -} module GHC.Rename.Pat (-- main entry points-              rnPat, rnPats, rnBindPat, rnPatAndThen,+              rnPat, rnPats, rnBindPat,                NameMaker, applyNameMaker,     -- a utility for making names:               localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,@@ -77,7 +77,7 @@ import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt -import Control.Monad       ( when, ap, guard, forM, unless )+import Control.Monad       ( when, ap, guard, unless ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio@@ -551,10 +551,10 @@                                       (L l lit') lit' ge minus) }                 -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat _ rdr pat)+rnPatAndThen mk (AsPat _ rdr at pat)   = do { new_name <- newPatLName mk rdr        ; pat' <- rnLPatAndThen mk pat-       ; return (AsPat noExtField new_name pat') }+       ; return (AsPat noExtField new_name at pat') }  rnPatAndThen mk p@(ViewPat _ expr pat)   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns@@ -609,15 +609,13 @@        ; return (SumPat noExtField 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 }+           (rn_splice, HsUntypedSpliceTop mfs pat) -> -- Splice was top-level and thus run, creating Pat GhcPs+               gParPat . (fmap (flip SplicePat rn_splice . HsUntypedSpliceTop mfs)) <$> rnLPatAndThen mk pat+           (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed+       }  -------------------- rnConPatAndThen :: NameMaker@@ -628,8 +626,7 @@ rnConPatAndThen mk con (PrefixCon tyargs pats)   = do  { con' <- lookupConCps con         ; liftCps check_lang_exts-        ; tyargs' <- forM tyargs $ \t ->-            liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t+        ; tyargs' <- mapM rnConPatTyArg tyargs         ; pats' <- rnLPatsAndThen mk pats         ; return $ ConPat             { pat_con_ext = noExtField@@ -644,12 +641,15 @@       type_app      <- xoptM LangExt.TypeApplications       unless (scoped_tyvars && type_app) $         case listToMaybe tyargs of-          Nothing    -> pure ()+          Nothing -> pure ()           Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $             hang (text "Illegal visible type application in a pattern:"-                    <+> quotes (char '@' <> ppr tyarg))+                    <+> quotes (ppr tyarg))                2 (text "Both ScopedTypeVariables and TypeApplications are"                     <+> text "required to use this feature")+    rnConPatTyArg (HsConPatTyArg at t) = do+      t' <- liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t+      return (HsConPatTyArg at t')  rnConPatAndThen mk con (InfixCon pat1 pat2)   = do  { con' <- lookupConCps con
compiler/GHC/Rename/Splice.hs view
@@ -1,14 +1,20 @@-+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module GHC.Rename.Splice (         rnTopSpliceDecls,-        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,++        -- Typed splices+        rnTypedSplice,+        -- Untyped splices+        rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceDecl,++        -- Brackets         rnTypedBracket, rnUntypedBracket,-        checkThLocalName-        , traceSplice, SpliceInfo(..)++        checkThLocalName, traceSplice, SpliceInfo(..)   ) where  import GHC.Prelude@@ -284,51 +290,43 @@ 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+rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))+                                                    -- Outside brackets, run splice+                   -> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a))+                                                   -- Inside brackets, make it pending+                   -> HsUntypedSplice GhcPs+                   -> RnM (a, FreeVars)+rnUntypedSpliceGen 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 _ RnPendingTyped+          -> failWithTc illegalUntypedSplice          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'+          -> do { (splice', fvs) <- setStage pop_stage $+                                    rnUntypedSplice splice+                ; loc  <- getSrcSpanM+                ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)+                ; let (pending_splice, result) = pend_splice splice_name splice'                 ; ps <- readMutVar ps_var                 ; writeMutVar ps_var (pending_splice : ps)                 ; return (result, fvs) }          _ ->  do { checkTopSpliceAllowed splice                  ; (splice', fvs1) <- checkNoErrs $-                                         setStage (Splice splice_type) $-                                         rnSplice splice+                                      setStage (Splice Untyped) $+                                      rnUntypedSplice 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   -- Nested splices are fine without TemplateHaskell because they -- are not executed until the top-level splice is run.-checkTopSpliceAllowed :: HsSplice GhcPs -> RnM ()+checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM () checkTopSpliceAllowed splice = do   let (herald, ext) = spliceExtension splice   extEnabled <- xoptM ext@@ -336,11 +334,9 @@     (failWith $ TcRnUnknownMessage $ mkPlainError noHints $        text herald <+> text "are not permitted without" <+> ppr ext)   where-     spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)+     spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension)      spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)-     spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)-     spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)-     spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s)+     spliceExtension (HsUntypedSpliceExpr {}) = ("Top-level splices", LangExt.TemplateHaskell)  ------------------ @@ -352,7 +348,7 @@             -> (LHsExpr GhcTc -> TcRn res)             -> (res -> SDoc)    -- How to pretty-print res                                 -- Usually just ppr, but not for [Decl]-            -> HsSplice GhcRn   -- Always untyped+            -> HsUntypedSplice GhcRn             -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice   = do { hooks <- hsc_hooks <$> getTopEnv@@ -361,10 +357,8 @@             Just h  -> h 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)+                HsUntypedSpliceExpr _ e ->  e+                HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str               -- Typecheck the expression        ; meta_exp_ty   <- tcMetaTy meta_ty_name@@ -401,30 +395,28 @@  ------------------ makePending :: UntypedSpliceFlavour-            -> HsSplice GhcRn+            -> Name+            -> HsUntypedSplice GhcRn             -> PendingRnSplice-makePending flavour (HsUntypedSplice _ _ n e)+makePending flavour n (HsUntypedSpliceExpr _ 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 flavour n (HsQuasiQuote _ quoter quote)+  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter quote)  -------------------mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name+                 -> XRec GhcPs FastString                  -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote-mkQuasiQuoteExpr flavour quoter q_span' quote+mkQuasiQuoteExpr flavour quoter (L q_span' quote)   = L q_span $ HsApp noComments (L q_span              $ HsApp noComments (L q_span                     (HsVar noExtField (L (la2na q_span) quote_selector)))                                 quoterExpr)                     quoteExpr   where-    q_span = noAnnSrcSpan q_span'+    q_span = noAnnSrcSpan (locA q_span')     quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)     quoteExpr  = L q_span $! HsLit noComments $! HsString NoSourceText quote     quote_selector = case flavour of@@ -434,66 +426,90 @@                        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 (noAnnSrcSpan 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 (noAnnSrcSpan loc) splice_name)-        ; (expr', fvs) <- rnLExpr expr-        ; return (HsUntypedSplice x hasParen n' expr', fvs) }+unqualSplice :: RdrName+-- The RdrName for a SplicePointName.  See GHC.Hs.Expr+-- Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- We use "spn" (which is arbitrary) because it is brief but greppable-for.+unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn")) -rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)-  = do  { loc  <- getSrcSpanM-        ; splice_name' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name)+rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars)+-- Not exported...used for all+rnUntypedSplice (HsUntypedSpliceExpr annCo expr)+  = do  { (expr', fvs) <- rnLExpr expr+        ; return (HsUntypedSpliceExpr annCo expr', fvs) } -          -- Rename the quoter; akin to the HsVar case of rnExpr+rnUntypedSplice (HsQuasiQuote ext quoter quote)+  = do  { -- 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)+        ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }  ----------------------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 noAnn rn_splice)+rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression+              -> RnM (HsExpr GhcRn, FreeVars)+rnTypedSplice expr+  = addErrCtxt (hang (text "In the typed splice:") 2 (pprTypedSplice Nothing expr)) $ do+    { stage <- getStage+    ; case stage of+        Brack pop_stage RnPendingTyped+          -> setStage pop_stage 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 [Free variables of typed splices] above-             traceRn "rnSpliceExpr: typed expression splice" empty-           ; lcl_rdr <- getLocalRdrEnv-           ; gbl_rdr <- getGlobalRdrEnv-           ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr-                                                     , isLocalGRE gre]-                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)+        Brack _ (RnPendingUntyped _)+          -> failWithTc illegalTypedSplice -           ; return (HsSpliceE noAnn rn_splice, lcl_names `plusFV` gbl_names) }+        _ -> do { extEnabled <- xoptM LangExt.TemplateHaskell+                ; unless extEnabled+                    (failWith $ TcRnUnknownMessage $ mkPlainError noHints $+                       text "Top-level splices are not permitted without"+                         <+> ppr LangExt.TemplateHaskell) -      | otherwise  -- Run it here, see Note [Running splices in the Renamer]-      = do { traceRn "rnSpliceExpr: untyped expression splice" empty+                ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_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++                  -- Run typed splice later, in the type checker+                  -- Ugh!  See Note [Free variables of typed splices] above+                ; traceRn "rnTypedSplice: typed expression splice" empty+                ; lcl_rdr <- getLocalRdrEnv+                ; gbl_rdr <- getGlobalRdrEnv+                ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr+                                                          , isLocalGRE gre]+                      lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)+                      fvs2      = lcl_names `plusFV` gbl_names++                ; return (result, fvs1 `plusFV` fvs2) } }+  where+    rn_splice :: RnM (HsExpr GhcRn, FreeVars)+    rn_splice =+      do { loc <- getSrcSpanM+         -- The renamer allocates a splice-point name to every typed splice+         -- (incl the top level ones for which it will not ultimately be used)+         ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)+         ; (expr', fvs) <- rnLExpr expr+         ; return (HsTypedSplice n' expr', fvs) }++rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnUntypedSpliceExpr splice+  = rnUntypedSpliceGen run_expr_splice pend_expr_splice splice+  where+    pend_expr_splice :: Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)+    pend_expr_splice name rn_splice+        = (makePending UntypedExpSplice name rn_splice, HsUntypedSplice (HsUntypedSpliceNested name) rn_splice)++    run_expr_splice :: HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)+    run_expr_splice rn_splice+      = do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty+             -- Run it here, see Note [Running splices in the Renamer]            ; (rn_expr, mod_finalizers) <-                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)              -- See Note [Delaying modFinalizers in untyped splices].-           ; let e =  HsSpliceE noAnn-                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                    . HsSplicedExpr+           ; let e =  flip HsUntypedSplice rn_splice+                    . HsUntypedSpliceTop (ThModFinalizers mod_finalizers)                         <$> lexpr3            ; return (gHsPar e, fvs)            }@@ -649,13 +665,13 @@ -}  -----------------------rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)+rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars) rnSpliceType splice-  = rnSpliceGen run_type_splice pend_type_splice splice+  = rnUntypedSpliceGen run_type_splice pend_type_splice splice   where-    pend_type_splice rn_splice-       = ( makePending UntypedTypeSplice rn_splice-         , HsSpliceTy noExtField rn_splice)+    pend_type_splice name rn_splice+       = ( makePending UntypedTypeSplice name rn_splice+         , HsSpliceTy (HsUntypedSpliceNested name) rn_splice)      run_type_splice rn_splice       = do { traceRn "rnSpliceType: untyped type splice" empty@@ -666,10 +682,9 @@                                     -- checkNoErrs: see Note [Renamer errors]              -- See Note [Delaying modFinalizers in untyped splices].            ; return ( HsParTy noAnn-                              $ HsSpliceTy noExtField-                              . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                              . HsSplicedTy <$>-                              hs_ty3+                              $ flip HsSpliceTy rn_splice+                              . HsUntypedSpliceTop (ThModFinalizers mod_finalizers)+                                  <$> hs_ty3                     , fvs                     ) }               -- Wrap the result of the splice in parens so that we don't@@ -717,50 +732,43 @@  ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat]-rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)-                                       , FreeVars)+rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))+                                            , FreeVars) rnSplicePat splice-  = rnSpliceGen run_pat_splice pend_pat_splice splice+  = rnUntypedSpliceGen 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))+    pend_pat_splice name rn_splice+      = (makePending UntypedPatSplice name rn_splice+        , (rn_splice, HsUntypedSpliceNested name)) -- Pat splice is nested and thus simply renamed -    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].-           ; let p =  SplicePat noExtField-                    . HsSpliced noExtField (ThModFinalizers mod_finalizers)-                    . HsSplicedPat-                        <$> pat-           ; return (Left $ gParPat p, emptyFVs) }+           ; let p = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) pat+           ; return ((rn_splice, p), 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+  = rnUntypedSpliceGen run_decl_splice pend_decl_splice splice   where-    pend_decl_splice rn_splice-       = ( makePending UntypedDeclSplice rn_splice+    pend_decl_splice name rn_splice+       = ( makePending UntypedDeclSplice name rn_splice          , SpliceDecl noExtField (L loc rn_splice) flg) -    run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (ppr rn_splice)+    run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice) -rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)+rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module rnTopSpliceDecls splice    =  do { checkTopSpliceAllowed splice          ; (rn_splice, fvs) <- checkNoErrs $                                setStage (Splice Untyped) $-                               rnSplice splice+                               rnUntypedSplice splice            -- As always, be sure to checkNoErrs above lest we end up with            -- holes making it to typechecking, hence #12584.            --@@ -803,33 +811,33 @@ 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+splices), so we really want to return a (Pat GhcPs) -- 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+it to an HsUntypedSplice 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.+In any case, when we're done in rnSplicePat, we'll have both the renamed+splice, and either a Pat RdrName and ThModFinalizers (the result of running a+top-level splice) or a splice point name. Thus, rnSplicePat returns both+HsUntypedSplice GhcRn, and HsUntypedSpliceResult (Pat GhcPs) -- which models+the existence of either the result of running the splice (HsUntypedSpliceTop),+or its splice point name if nested (HsUntypedSpliceNested) -} -spliceCtxt :: HsSplice GhcPs -> SDoc+spliceCtxt :: HsUntypedSplice GhcPs -> SDoc spliceCtxt splice-  = hang (text "In the" <+> what) 2 (ppr splice)+  = hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice)   where     what = case splice of-             HsUntypedSplice {} -> text "untyped splice:"-             HsTypedSplice   {} -> text "typed splice:"-             HsQuasiQuote    {} -> text "quasi-quotation:"-             HsSpliced       {} -> text "spliced expression:"+             HsUntypedSpliceExpr {} -> text "untyped splice:"+             HsQuasiQuote        {} -> text "quasi-quotation:"  -- | The splice data to be logged data SpliceInfo
compiler/GHC/Rename/Splice.hs-boot view
@@ -1,14 +1,13 @@ module GHC.Rename.Splice where -import GHC.Prelude import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Types.Name.Set  -rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)-rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)-                                          , FreeVars )+rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars)+rnSplicePat  :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))+                                             , FreeVars) rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)+rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
compiler/GHC/Rename/Utils.hs view
@@ -674,7 +674,7 @@ genHsVar nm = HsVar noExtField $ wrapGenSpan nm  genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn-genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan+genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty))  genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -133,7 +133,7 @@ constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do    let occName = mkOccName OccName.dataName occ        modName = mkModule (stringToUnit pkg) (mkModuleName mod)-   Right `fmap` lookupOrigIO hsc_env modName occName+   Right `fmap` lookupNameCache (hsc_NC hsc_env) modName occName constrClosToName _hsc_env clos =    return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
compiler/GHC/Stg/InferTags.hs view
@@ -82,7 +82,7 @@ It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs. -This works analogous to how `StrictWorkerId`s work. See also Note [Strict Worker Ids].+This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids].  Why do we care? Because if we have code like: @@ -121,7 +121,7 @@ So we do our best to establish that `x` is already tagged (which it almost always is) to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions. -Note that there are similar constraints around Note [Strict Worker Ids].+Note that there are similar constraints around Note [CBV Function Ids].  Note [How untagged pointers can end up in strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -186,7 +186,8 @@ it made the code simpler. But besides implementation complexity there isn't any reason why we couldn't be more rigourous in dealing with functions. -NB: It turned out because of #21193 option two wouldn't really have been an option anyway.+NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions.+So option two isn't really an option without reworking this anyway.  Note [Tag inference debugging] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Stg/InferTags/Rewrite.hs view
@@ -91,7 +91,7 @@ At runtime what happens is that the wrapper will allocate a PAP which once fully applied will call the worker. And all is fine. -But what about a strict worker! Well the function returned by `f` would+But what about a call by value function! Well the function returned by `f` would be a unknown call, so we lose the ability to enfore the invariant that cbv marked arguments from StictWorkerId's are actually properly tagged as the annotations would be unavailable at the (unknown) call site.
compiler/GHC/Stg/Lint.hs view
@@ -382,7 +382,7 @@   when (lf_unarised lf) $ do     -- A function which expects a unlifted argument as n'th argument     -- always needs to be applied to n arguments.-    -- See Note [Strict Worker Ids].+    -- See Note [CBV Function Ids].     let marks = fromMaybe [] $ idCbvMarks_maybe fun     when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do       addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $
compiler/GHC/StgToByteCode.hs view
@@ -69,7 +69,7 @@ import GHC.Types.Tickish  import Data.List ( genericReplicate, genericLength, intersperse-                 , partition, scanl', sort, sortBy, zip4, zip6, nub )+                 , partition, scanl', sortBy, zip4, zip6 ) import Foreign hiding (shiftL, shiftR) import Control.Monad import Data.Char@@ -89,6 +89,7 @@ import Data.Either ( partitionEithers )  import GHC.Stg.Syntax+import qualified Data.IntSet as IntSet  -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module@@ -991,16 +992,16 @@          pointers =           extra_pointers ++-          sort (filter (< bitmap_size') (map (+extra_slots) rel_slots))+          filter (< bitmap_size') (map (+extra_slots) rel_slots)           where-          binds = Map.toList p           -- NB: unboxed tuple cases bind the scrut binder to the same offset           -- as one of the alt binders, so we have to remove any duplicates here:-          rel_slots = nub $ map fromIntegral $ concatMap spread binds-          spread (id, offset) | isUnboxedTupleType (idType id) ||-                                isUnboxedSumType (idType id) = []-                              | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]-                              | otherwise                      = []+          -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'.+          rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p+          spread id offset | isUnboxedTupleType (idType id) ||+                             isUnboxedSumType (idType id) = Nothing+                           | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset)+                           | otherwise                      = Nothing                 where rel_offset = trunc16W $ bytesToWords platform (d - offset)          bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers
compiler/GHC/StgToCmm/Bind.hs view
@@ -221,7 +221,6 @@ {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)   = do-    checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args     profile <- getProfile     check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig     use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig@@ -490,6 +489,7 @@      lf_info  = closureLFInfo cl_info      info_tbl = mkCmmInfo cl_info bndr cc +-- Functions closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details   = let nv_args = nonVoidIds args         arity = length args@@ -531,7 +531,7 @@                 -- Load free vars out of closure *after*                 -- heap check, to reduce live vars over check                 ; when node_points $ load_fvs node lf_info fv_bindings-                ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr (map fromNonVoid nv_args)+                ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args                 ; void $ cgExpr body                 }}}
compiler/GHC/StgToCmm/TagCheck.hs view
@@ -43,17 +43,16 @@  import qualified Data.Map as M --- | Check all arguments marked as already tagged for a function--- are tagged by inserting runtime checks.+-- | Check all arguments marked as cbv for the presence of a tag *at runtime*. checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode () checkFunctionArgTags msg f args = whenCheckTags $ do   onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do     -- Only check args marked as strict, and only lifted ones.-    let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+    let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args     -- Get their (cmm) address     arg_infos <- mapM getCgIdInfo cbv_args     let arg_cmms = map idInfoToAmode arg_infos-    mapM_ (emitTagAssertion (showPprUnsafe msg))  (arg_cmms)+    mapM_ (\(cmm,arg) -> emitTagAssertion (showPprUnsafe $ msg <+> ppr arg) cmm)  (zip arg_cmms cbv_args)  -- | Check all required-tagged arguments of a constructor are tagged *at compile time*. checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()@@ -133,7 +132,7 @@ emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode () emitArgTagCheck info marks args = whenCheckTags $ do   mod <- getModuleName-  let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args+  let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args   arg_infos <- mapM getCgIdInfo cbv_args   let arg_cmms = map idInfoToAmode arg_infos       mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -852,7 +852,7 @@      enum_index       = mkSimpleGeneratedFunBind loc unsafeIndex_RDR-                [noLocA (AsPat noAnn (noLocA c_RDR)+                [noLocA (AsPat noAnn (noLocA c_RDR) noHsTok                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),                                 d_Pat] (            untag_Expr [(a_RDR, ah_RDR)] (@@ -1661,8 +1661,8 @@     mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField     mk_typed_bracket = HsTypedBracket noAnn -    mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice-    mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice+    mk_tsplice = HsTypedSplice (EpAnnNotUsed, noAnn)+    mk_usplice = HsUntypedSplice EpAnnNotUsed . HsUntypedSpliceExpr noAnn     data_cons = getPossibleDataCons tycon tycon_args      pats_etc mk_bracket mk_splice lift_name data_con@@ -1677,7 +1677,7 @@                                     (map lift_var as_needed)              lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)-            lift_var x   = noLocA (HsSpliceE EpAnnNotUsed (mk_splice x (nlHsPar (mk_lift_expr x))))+            lift_var x   = noLocA (mk_splice (nlHsPar (mk_lift_expr x)))              mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)             mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]@@ -2105,7 +2105,7 @@         rep_cvs'    = scopedSort rep_cvs  nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs-nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)+nlHsAppType e s = noLocA (HsAppType noExtField e noHsTok hs_ty)   where     hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
compiler/GHC/Tc/Gen/App.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-} {-# LANGUAGE GADTs               #-}-{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]@@ -22,21 +21,14 @@  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Types.Basic ( Arity, ExprOrPat(Expression) )-import GHC.Types.Id ( idArity, idName, hasNoBinding )-import GHC.Types.Name ( isWiredInName ) import GHC.Types.Var import GHC.Builtin.Types ( multiplicityTy )-import GHC.Core.ConLike  ( ConLike(..) )-import GHC.Core.DataCon ( dataConRepArity-                        , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon ) import GHC.Tc.Gen.Head import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType@@ -331,28 +323,16 @@ -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty   | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr-  = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args+  = do { traceTc "tcApp {" $+           vcat [ text "rn_fun:" <+> ppr rn_fun+                , text "rn_args:" <+> ppr rn_args ] +       ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args+        -- Instantiate        ; do_ql <- wantQuickLook rn_fun        ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args -       -- Check for representation polymorphism in the case that-       -- the head of the application is a primop or data constructor-       -- which has argument types that are representation-polymorphic.-       -- This amounts to checking that the leftover argument types,-       -- up until the arity, are not representation-polymorphic,-       -- so that we can perform eta-expansion later without introducing-       -- representation-polymorphic binders.-       ---       -- See Note [Checking for representation-polymorphic built-ins]-       ; traceTc "tcApp FRR" $-           vcat-             [ text "tc_fun =" <+> ppr tc_fun-             , text "inst_args =" <+> ppr inst_args-             , text "app_res_rho =" <+> ppr app_res_rho ]-       ; hasFixedRuntimeRep_remainingValArgs inst_args app_res_rho tc_fun-        -- Quick look at result        ; app_res_rho <- if do_ql                         then quickLookResultType delta app_res_rho exp_res_ty@@ -375,239 +355,33 @@        ; res_co <- perhaps_add_res_ty_ctxt $                    unifyExpectedType rn_expr app_res_rho exp_res_ty -       ; whenDOptM Opt_D_dump_tc_trace $-         do { inst_args <- mapM zonkArg inst_args  -- Only when tracing-            ; traceTc "tcApp" (vcat [ text "rn_fun"       <+> ppr rn_fun-                               , text "inst_args"    <+> brackets (pprWithCommas pprHsExprArgTc inst_args)-                               , text "do_ql:  "     <+> ppr do_ql-                               , text "fun_sigma:  " <+> ppr fun_sigma-                               , text "delta:      " <+> ppr delta-                               , text "app_res_rho:" <+> ppr app_res_rho-                               , text "exp_res_ty:"  <+> ppr exp_res_ty-                               , text "rn_expr:"     <+> ppr rn_expr ]) }-        -- Typecheck the value arguments        ; tc_args <- tcValArgs do_ql inst_args -       -- Reconstruct, with a special cases for tagToEnum#.+       -- Reconstruct, with a special case for tagToEnum#.        ; tc_expr <-           if isTagToEnum rn_fun           then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho-          else do return (rebuildHsApps tc_fun fun_ctxt tc_args)+          else do rebuildHsApps tc_fun fun_ctxt tc_args app_res_rho +       ; whenDOptM Opt_D_dump_tc_trace $+         do { inst_args <- mapM zonkArg inst_args  -- Only when tracing+            ; traceTc "tcApp }" (vcat [ text "rn_fun:"      <+> ppr rn_fun+                                      , text "rn_args:"     <+> ppr rn_args+                                      , text "inst_args"    <+> brackets (pprWithCommas pprHsExprArgTc inst_args)+                                      , text "do_ql:  "     <+> ppr do_ql+                                      , text "fun_sigma:  " <+> ppr fun_sigma+                                      , text "delta:      " <+> ppr delta+                                      , text "app_res_rho:" <+> ppr app_res_rho+                                      , text "exp_res_ty:"  <+> ppr exp_res_ty+                                      , text "rn_expr:"     <+> ppr rn_expr+                                      , text "tc_fun:"      <+> ppr tc_fun+                                      , text "tc_args:"     <+> ppr tc_args+                                      , text "tc_expr:"     <+> ppr tc_expr ]) }+        -- Wrap the result        ; return (mkHsWrapCo res_co tc_expr) } -{--Note [Checking for representation-polymorphic built-ins]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We cannot have representation-polymorphic or levity-polymorphic-function arguments. See Note [Representation polymorphism invariants]-in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in-`tcEValArg`.--But some /built-in/ functions have representation-polymorphic argument-types. Users can't define such Ids; they are all GHC built-ins or data-constructors.  Specifically they are:--1. A few wired-in Ids like unsafeCoerce#, with compulsory unfoldings.-2. Primops, such as raise#.-3. Newtype constructors with `UnliftedNewtypes` that have-   a representation-polymorphic argument.-4. Representation-polymorphic data constructors: unboxed tuples-   and unboxed sums.--For (1) consider-  badId :: forall r (a :: TYPE r). a -> a-  badId = unsafeCoerce# @r @r @a @a--The wired-in function-  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)-                   (a :: TYPE r1) (b :: TYPE r2).-                   a -> b-has a convenient but representation-polymorphic type. It has no-binding; instead it has a compulsory unfolding, after which we-would have-  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...-And this is no good because of that rep-poly \(x::a).  So we want-to reject this.--On the other hand-  goodId :: forall (a :: Type). a -> a-  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a--is absolutely fine, because after we inline the unfolding, the \(x::a)-is representation-monomorphic.--Test cases: T14561, RepPolyWrappedVar2.--For primops (2) the situation is similar; they are eta-expanded in-CorePrep to be saturated, and that eta-expansion must not add a-representation-polymorphic lambda.--Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.--For (3), consider a representation-polymorphic newtype with-UnliftedNewtypes:--  type Id :: forall r. TYPE r -> TYPE r-  newtype Id a where { MkId :: a }--  bad :: forall r (a :: TYPE r). a -> Id a-  bad = MkId @r @a             -- Want to reject--  good :: forall (a :: Type). a -> Id a-  good = MkId @LiftedRep @a   -- Want to accept--Test cases: T18481, UnliftedNewtypesLevityBinder--So these three cases need special treatment. We add a special case-in tcApp to check whether an application of an Id has any remaining-representation-polymorphic arguments, after instantiation and application-of previous arguments.  This is achieved by the hasFixedRuntimeRep_remainingValArgs-function, which computes the types of the remaining value arguments, and checks-that each of these have a fixed runtime representation using hasFixedRuntimeRep.--Wrinkles--* Because of Note [Typechecking data constructors] in GHC.Tc.Gen.Head,-  we desugar a representation-polymorphic data constructor application-  like this:-     (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4-  That is, a rep-poly lambda applied to arguments that instantiate it in-  a rep-mono way.  It's a bit like a compulsory unfolding that has been-  inlined, but not yet beta-reduced.--  Because we want to accept this, we switch off Lint's representation-  polymorphism checks when Lint checks the output of the desugarer;-  see the lf_check_fixed_rep flag in GHC.Core.Lint.lintCoreBindings.--  We then rely on the simple optimiser to beta reduce these-  representation-polymorphic lambdas (e.g. GHC.Core.SimpleOpt.simple_app).--* Arity.  We don't want to check for arguments past the-  arity of the function.  For example--      raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b--  has arity 1, so an instantiation such as:--      foo :: forall w r (z :: TYPE r). w -> z -> z-      foo = raise# @w @(z -> z)--  is unproblematic.  This means we must take care not to perform a-  representation-polymorphism check on `z`.--  To achieve this, we consult the arity of the 'Id' which is the head-  of the application (or just use 1 for a newtype constructor),-  and keep track of how many value-level arguments we have seen,-  to ensure we stop checking once we reach the arity.-  This is slightly complicated by the need to include both visible-  and invisible arguments, as the arity counts both:-  see GHC.Tc.Gen.Head.countVisAndInvisValArgs.--  Test cases: T20330{a,b}---}---- | Check for representation-polymorphism in the remaining argument types--- of a variable or data constructor, after it has been instantiated and applied to some arguments.------ See Note [Checking for representation-polymorphic built-ins]-hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM ()-hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case--  HsVar _ (L _ fun_id)--    -- (1): unsafeCoerce#-    -- 'unsafeCoerce#' is peculiar: it is patched in manually as per-    -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore.-    -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair,-    -- at this stage, if we query idArity, we get 0. This is because-    -- we end up looking at the non-patched version of unsafeCoerce#-    -- defined in Unsafe.Coerce, and that one indeed has arity 0.-    ---    -- We thus manually specify the correct arity of 1 here.-    | idName fun_id == unsafeCoercePrimName-    -> check_thing fun_id 1 (FRRNoBindingResArg fun_id)--    -- (2): primops and other wired-in representation-polymorphic functions,-    -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings-    -- in GHC.Types.Id.Make-    | isWiredInName (idName fun_id) && hasNoBinding fun_id-    -> check_thing fun_id (idArity fun_id) (FRRNoBindingResArg fun_id)-       -- NB: idArity consults the IdInfo of the Id. This can be a problem-       -- in the presence of hs-boot files, as we might not have finished-       -- typechecking; inspecting the IdInfo at this point can cause-       -- strange Core Lint errors (see #20447).-       -- We avoid this entirely by only checking wired-in names,-       -- as those are the only ones this check is applicable to anyway.---  XExpr (ConLikeTc (RealDataCon con) _ _)-  -- (3): Representation-polymorphic newtype constructors.-    | isNewDataCon con-  -- (4): Unboxed tuples and unboxed sums-    || isUnboxedTupleDataCon con-    || isUnboxedSumDataCon con-    -> check_thing con (dataConRepArity con) (FRRDataConArg Expression con)--  _ -> return ()--  where-    nb_applied_vis_val_args :: Int-    nb_applied_vis_val_args = count isHsValArg applied_args--    nb_applied_val_args :: Int-    nb_applied_val_args = countVisAndInvisValArgs applied_args--    arg_tys :: [(Type,AnonArgFlag)]-    arg_tys = getRuntimeArgTys app_res_rho-    -- We do not need to zonk app_res_rho first, because the number of arrows-    -- in the (possibly instantiated) inferred type of the function will-    -- be at least the arity of the function.--    check_thing :: Outputable thing-                => thing-                -> Arity-                -> (Int -> FixedRuntimeRepContext)-                -> TcM ()-    check_thing thing arity mk_frr_orig = do-      traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity)-      go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys-      where-        go :: Int -- visible value argument index, starting from 1-                  -- only used to report the argument position in error messages-           -> Int -- value argument index, starting from 1-                  -- used to count up to the arity to ensure we don't check too many argument types-           -> [(Type, AnonArgFlag)] -- run-time argument types-           -> TcM ()-        go _ i_val _-          | i_val > arity-          = return ()-        go _ _ []-          -- Should never happen: it would mean that the arity is higher-          -- than the number of arguments apparent from the type-          = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity)-        go i_visval !i_val ((arg_ty, af) : tys)-          = case af of-              InvisArg ->-                go i_visval (i_val + 1) tys-              VisArg   -> do-                hasFixedRuntimeRep_syntactic (mk_frr_orig i_visval) arg_ty-                go (i_visval + 1) (i_val + 1) tys--    -- A message containing all the relevant info, in case this functions-    -- needs to be debugged again at some point.-    debug_msg :: Outputable thing => thing -> Arity -> SDoc-    debug_msg thing arity =-      vcat-        [ text "thing =" <+> ppr thing-        , text "arity =" <+> ppr arity-        , text "applied_args =" <+> ppr applied_args-        , text "nb_applied_val_args =" <+> ppr nb_applied_val_args-        , text "arg_tys =" <+> ppr arg_tys ]- -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool -- GHC switches on impredicativity all the time for ($)@@ -645,6 +419,7 @@   ----------------+ tcValArgs :: Bool                    -- Quick-look on?           -> [HsExprArg 'TcpInst]    -- Actual argument           -> TcM [HsExprArg 'TcpTc]  -- Resulting argument@@ -652,9 +427,9 @@   = mapM tc_arg args   where     tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)-    tc_arg (EPrag l p)           = return (EPrag l (tcExprPrag p))-    tc_arg (EWrap w)             = return (EWrap w)-    tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)+    tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p))+    tc_arg (EWrap w)   = return (EWrap w)+    tc_arg (ETypeArg l at hs_ty ty) = return (ETypeArg l at hs_ty ty)      tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty                         , eva_ctxt = ctxt })@@ -694,9 +469,13 @@   = addArgCtxt ctxt larg $     do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])        ; tc_args <- tcValArgs True inner_args-       ; co      <- unifyType Nothing app_res_rho exp_arg_sigma-       ; let arg' = mkHsWrapCo co $ rebuildHsApps inner_fun fun_ctxt tc_args-       ; traceTc "tcEValArgQL }" empty++       ; co   <- unifyType Nothing app_res_rho exp_arg_sigma+       ; arg' <- mkHsWrapCo co <$> rebuildHsApps inner_fun fun_ctxt tc_args app_res_rho+       ; traceTc "tcEValArgQL }" $+           vcat [ text "inner_fun:" <+> ppr inner_fun+                , text "app_res_rho:" <+> ppr app_res_rho+                , text "exp_arg_sigma:" <+> ppr exp_arg_sigma ]        ; return (L arg_loc arg') }  {- *********************************************************************@@ -815,14 +594,14 @@       = go1 delta (EPrag sp prag : acc) so_far fun_ty args      -- Rule ITYARG from Fig 4 of the QL paper-    go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty }+    go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_at = at, eva_hs_ty = hs_ty }                                 : rest_args )       | fun_is_out_of_scope   -- See Note [VTA for out-of-scope functions]       = go delta acc so_far fun_ty rest_args        | otherwise       = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty-           ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty, eva_ty = ty_arg }+           ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_at = at, eva_hs_ty = hs_ty, eva_ty = ty_arg }            ; go delta (arg' : acc) so_far inst_ty rest_args }      -- Rule IVAR from Fig 4 of the QL paper:@@ -1418,15 +1197,15 @@          check_enumeration res_ty rep_tc        ; let rep_ty  = mkTyConApp rep_tc rep_args              tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun-             tc_expr = rebuildHsApps tc_fun' fun_ctxt [val_arg]              df_wrap = mkWpCastR (mkTcSymCo coi)+       ; tc_expr <- rebuildHsApps tc_fun' fun_ctxt [val_arg] res_ty        ; return (mkHsWrap df_wrap tc_expr) }}}}}    | otherwise   = failWithTc TcRnTagToEnumMissingValArg    where-    vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args)+    vanilla_result = rebuildHsApps tc_fun fun_ctxt tc_args res_ty      check_enumeration ty' tc       | isEnumerationTyCon tc = return ()
compiler/GHC/Tc/Gen/Bind.hs view
@@ -505,7 +505,7 @@     ; traceTc "Generalisation plan" (ppr plan)     ; result@(_, poly_ids) <- case plan of          NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list-         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list+         InferGen           -> tcPolyInfer rec_tc prag_fn sig_fn bind_list          CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind      ; mapM_ (\ poly_id ->@@ -698,20 +698,20 @@   :: RecFlag       -- Whether it's recursive after breaking                    -- dependencies based on type signatures   -> TcPragEnv -> TcSigFun-  -> Bool         -- True <=> apply the monomorphism restriction   -> [LHsBind GhcRn]   -> TcM (LHsBinds GhcTc, [TcId])-tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list+tcPolyInfer rec_tc prag_fn tc_sig_fn bind_list   = do { (tclvl, wanted, (binds', mono_infos))              <- pushLevelAndCaptureConstraints  $                 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list +       ; apply_mr <- checkMonomorphismRestriction mono_infos bind_list+       ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos))+        ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))                           | info <- mono_infos ]              sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]-             infer_mode = if mono then ApplyMR else NoRestrictions--       ; mapM_ (checkOverloadedSig mono) sigs+             infer_mode = if apply_mr then ApplyMR else NoRestrictions         ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)        ; ((qtvs, givens, ev_binds, insoluble), residual)@@ -740,6 +740,59 @@        ; return (unitBag abs_bind, poly_ids) }          -- poly_ids are guaranteed zonked by mkExport +checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool+-- True <=> apply the MR+checkMonomorphismRestriction mbis lbinds+  | null partial_sigs  -- The normal case+  = do { mr_on <- xoptM LangExt.MonomorphismRestriction+       ; let mr_applies = mr_on && any (restricted . unLoc) lbinds+       ; when mr_applies $ mapM_ checkOverloadedSig sigs+       ; return mr_applies }++  | otherwise    -- See Note [Partial type signatures and the monomorphism restriction]+  = return (all is_mono_psig partial_sigs)++  where+    sigs, partial_sigs :: [TcIdSigInst]+    sigs          = [sig | MBI { mbi_sig = Just sig } <- mbis]+    partial_sigs  = [sig | sig@(TISI { sig_inst_sig = PartialSig {} }) <- sigs]++    complete_sig_bndrs :: NameSet+    complete_sig_bndrs+      = mkNameSet [ idName bndr+                  | TISI { sig_inst_sig = CompleteSig { sig_bndr = bndr }} <- sigs ]++    is_mono_psig (TISI { sig_inst_theta = theta, sig_inst_wcx = mb_extra_constraints })+       = null theta && isNothing mb_extra_constraints++    -- The Haskell 98 monomorphism restriction+    restricted (PatBind {})                              = True+    restricted (VarBind { var_id = v })                  = no_sig v+    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m+                                                           && no_sig (unLoc v)+    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)++    restricted_match mg = matchGroupArity mg == 0+        -- No args => like a pattern binding+        -- Some args => a function binding++    no_sig nm = not (nm `elemNameSet` complete_sig_bndrs)++checkOverloadedSig :: TcIdSigInst -> TcM ()+-- Example:+--   f :: Eq a => a -> a+--   K f = e+-- The MR applies, but the signature is overloaded, and it's+-- best to complain about this directly+-- c.f #11339+checkOverloadedSig sig+  | not (null (sig_inst_theta sig))+  , let orig_sig = sig_inst_sig sig+  = setSrcSpan (sig_loc orig_sig) $+    failWith $ TcRnOverloadedSig orig_sig+  | otherwise+  = return ()+ -------------- mkExport :: TcPragEnv          -> WantedConstraints  -- residual constraints, already emitted (for errors only)@@ -994,22 +1047,6 @@         ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty         ; addDiagnosticTcM (env1, dia) } -checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()--- Example:---   f :: Eq a => a -> a---   K f = e--- The MR applies, but the signature is overloaded, and it's--- best to complain about this directly--- c.f #11339-checkOverloadedSig monomorphism_restriction_applies sig-  | not (null (sig_inst_theta sig))-  , monomorphism_restriction_applies-  , let orig_sig = sig_inst_sig sig-  = setSrcSpan (sig_loc orig_sig) $-    failWith $ TcRnOverloadedSig orig_sig-  | otherwise-  = return ()- {- Note [Partial type signatures and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If /any/ of the signatures in the group is a partial type signature@@ -1035,14 +1072,33 @@ doesn't seem much point.  Indeed, adding a partial type signature is a way to get per-binding inferred generalisation. -We apply the MR if /all/ of the partial signatures lack a context.-In particular (#11016):+Note [Partial type signatures and the monomorphism restriction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We apply the MR if /none/ of the partial signatures has a context. e.g.+   f :: _ -> Int+   f x = rhs+The partial type signature says, in effect, "there is no context", which+amounts to appplying the MR. Indeed, saying+   f :: _+   f = rhs+is a way for forcing the MR to apply.++But we /don't/ want to apply the MR if the partial signatures do have+a context  e.g. (#11016):    f2 :: (?loc :: Int) => _    f2 = ?loc It's stupid to apply the MR here.  This test includes an extra-constraints wildcard; that is, we don't apply the MR if you write    f3 :: _ => blah +But watch out.  We don't want to apply the MR to+   type Wombat a = forall b. Eq b => ...b...a...+   f4 :: Wombat _+Here f4 doesn't /look/ as if it has top-level overloading, but in fact it+does, hidden under Wombat.  We can't "see" that because we only have access+to the HsType at the moment.  That's why we do the check in+checkMonomorphismRestriction.+ Note [Quantified variables in partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1632,79 +1688,55 @@   = NoGen               -- No generalisation, no AbsBinds    | InferGen            -- Implicit generalisation; there is an AbsBinds-       Bool             --   True <=> apply the MR; generalise only unconstrained type vars -  | CheckGen (LHsBind GhcRn) TcIdSigInfo-                        -- One FunBind with a signature-                        -- Explicit generalisation+  | CheckGen            -- One FunBind with a complete signature:+       (LHsBind GhcRn)  --   do explicit generalisation+       TcIdSigInfo      -- Always CompleteSig  -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one  instance Outputable GeneralisationPlan where   ppr NoGen          = text "NoGen"-  ppr (InferGen b)   = text "InferGen" <+> ppr b+  ppr InferGen       = text "InferGen"   ppr (CheckGen _ s) = text "CheckGen" <+> ppr s  decideGeneralisationPlan    :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun    -> [LHsBind GhcRn] -> GeneralisationPlan decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds-  | has_partial_sigs                         = InferGen (and partial_sig_mrs)   | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig-  | do_not_generalise                        = NoGen-  | otherwise                                = InferGen mono_restriction+  | generalise_binds                         = InferGen+  | otherwise                                = NoGen   where-    binds = map unLoc lbinds--    partial_sig_mrs :: [Bool]-    -- One for each partial signature (so empty => no partial sigs)-    -- The Bool is True if the signature has no constraint context-    --      so we should apply the MR-    -- See Note [Partial type signatures and generalisation]-    partial_sig_mrs-      = [ null $ fromMaybeContext mtheta-        | TcIdSig (PartialSig { psig_hs_ty = hs_ty })-            <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds)-        , let (mtheta, _) = splitLHsQualTy (hsSigWcType hs_ty) ]--    has_partial_sigs = not (null partial_sig_mrs)--    mono_restriction  = xopt LangExt.MonomorphismRestriction dflags-                     && any restricted binds--    do_not_generalise-      | isTopLevel top_lvl             = False+    generalise_binds+      | isTopLevel top_lvl             = True         -- See Note [Always generalise top-level bindings] -      | IsGroupClosed _ True <- closed = False+      | IsGroupClosed _ True <- closed = True         -- The 'True' means that all of the group's         -- free vars have ClosedTypeId=True; so we can ignore         -- -XMonoLocalBinds, and generalise anyway -      | otherwise = xopt LangExt.MonoLocalBinds dflags+      | has_partial_sigs = True+        -- See Note [Partial type signatures and generalisation] +      | otherwise = not (xopt LangExt.MonoLocalBinds dflags)+     -- With OutsideIn, all nested bindings are monomorphic-    -- except a single function binding with a signature+    -- except a single function binding with a complete signature     one_funbind_with_sig       | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds-      , Just (TcIdSig sig) <- sig_fn (unLoc v)+      , Just (TcIdSig sig@(CompleteSig {})) <- sig_fn (unLoc v)       = Just (lbind, sig)       | otherwise       = Nothing -    -- The Haskell 98 monomorphism restriction-    restricted (PatBind {})                              = True-    restricted (VarBind { var_id = v })                  = no_sig v-    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m-                                                           && no_sig (unLoc v)-    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)--    restricted_match mg = matchGroupArity mg == 0-        -- No args => like a pattern binding-        -- Some args => a function binding--    no_sig n = not (hasCompleteSig sig_fn n)+    binders          = collectHsBindListBinders CollNoDictBinders lbinds+    has_partial_sigs = any has_partial_sig binders+    has_partial_sig nm = case sig_fn nm of+      Just (TcIdSig (PartialSig {})) -> True+      _                              -> False  isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed isClosedBndrGroup type_env binds
compiler/GHC/Tc/Gen/Expr.hs view
@@ -27,7 +27,7 @@  import GHC.Prelude -import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )+import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket )  import GHC.Hs import GHC.Hs.Syn.Type@@ -565,17 +565,18 @@ ************************************************************************ -} --- 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 GHC.Rename.Splice.-tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))-       res_ty-  = do addModFinalizersWithLclEnv mod_finalizers-       tcExpr expr res_ty-tcExpr (HsSpliceE _ splice)          res_ty = tcSpliceExpr splice res_ty-tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty+tcExpr (HsTypedSplice ext splice)   res_ty = tcTypedSplice ext splice res_ty+tcExpr e@(HsTypedBracket _ body)    res_ty = tcTypedBracket e body res_ty+ tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty+tcExpr (HsUntypedSplice splice _)   res_ty+  = case splice of+      HsUntypedSpliceTop mod_finalizers expr+        -> do { addModFinalizersWithLclEnv mod_finalizers+              ; tcExpr expr res_ty }+      HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice"  {- ************************************************************************
compiler/GHC/Tc/Gen/Head.hs view
@@ -43,6 +43,7 @@ import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv    ( FamInstEnvs )@@ -171,6 +172,7 @@              , eva_arg_ty :: !(XEVAType p) }    | ETypeArg { eva_ctxt  :: AppCtxt+             , eva_at    :: !(LHsToken "@" GhcRn)              , eva_hs_ty :: LHsWcType GhcRn  -- The type arg              , eva_ty    :: !(XETAType p) }  -- Kind-checked type arg @@ -262,9 +264,11 @@ mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt                            , eva_arg_ty = noExtField } -mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn-mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty-                                 , eva_ty = noExtField }+mkETypeArg :: AppCtxt -> LHsToken "@" GhcRn -> LHsWcType GhcRn -> HsExprArg 'TcpRn+mkETypeArg ctxt at hs_ty =+  ETypeArg { eva_ctxt = ctxt+           , eva_at = at, eva_hs_ty = hs_ty+           , eva_ty = noExtField }  addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst] addArgWrap wrap args@@ -283,7 +287,7 @@     -- See Note [AppCtxt]     top_ctxt n (HsPar _ _ fun _)           = top_lctxt n fun     top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun-    top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun+    top_ctxt n (HsAppType _ fun _ _)         = top_lctxt (n+1) fun     top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun     top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig      n noSrcSpan     top_ctxt n other_fun                   = VACall other_fun n noSrcSpan@@ -293,10 +297,10 @@     go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]        -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])     -- Modify the AppCtxt as we walk inwards, so it describes the next argument-    go (HsPar _ _ (L l fun) _)    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)-    go (HsPragE _ p (L l fun))    ctxt args = go fun (set l ctxt) (EPrag      ctxt p   : args)-    go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty  : args)-    go (HsApp _ (L l fun) arg)    ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg : args)+    go (HsPar _ _ (L l fun) _)       ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)     : args)+    go (HsPragE _ p (L l fun))       ctxt args = go fun (set l ctxt) (EPrag      ctxt p     : args)+    go (HsAppType _ (L l fun) at ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt at ty : args)+    go (HsApp _ (L l fun) arg)       ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg   : args)      -- See Note [Looking through HsExpanded]     go (XExpr (HsExpanded orig fun)) ctxt args@@ -321,25 +325,316 @@     dec l (VACall f n _)        = VACall f (n-1) (locA l)     dec _ ctxt@(VAExpansion {}) = ctxt -rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc-rebuildHsApps fun _ [] = fun-rebuildHsApps fun ctxt (arg : args)+-- | Rebuild an application: takes a type-checked application head+-- expression together with arguments in the form of typechecked 'HsExprArg's+-- and returns a typechecked application of the head to the arguments.+--+-- This performs a representation-polymorphism check to ensure that the+-- remaining value arguments in an application have a fixed RuntimeRep.+--+-- See Note [Checking for representation-polymorphic built-ins].+rebuildHsApps :: HsExpr GhcTc+                      -- ^ the function being applied+              -> AppCtxt+              -> [HsExprArg 'TcpTc]+                      -- ^ the arguments to the function+              -> TcRhoType+                      -- ^ result type of the application+              -> TcM (HsExpr GhcTc)+rebuildHsApps fun ctxt args app_res_rho+  = do { tcRemainingValArgs args app_res_rho fun+       ; return $ rebuild_hs_apps fun ctxt args }++-- | The worker function for 'rebuildHsApps': simply rebuilds+-- an application chain in which arguments are specified as+-- typechecked 'HsExprArg's.+rebuild_hs_apps :: HsExpr GhcTc+                      -- ^ the function being applied+              -> AppCtxt+              -> [HsExprArg 'TcpTc]+                      -- ^ the arguments to the function+              -> HsExpr GhcTc+rebuild_hs_apps fun _ [] = fun+rebuild_hs_apps fun ctxt (arg : args)   = case arg of       EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }-        -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args-      ETypeArg { eva_hs_ty = hs_ty, eva_ty  = ty, eva_ctxt = ctxt' }-        -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args+        -> rebuild_hs_apps (HsApp noAnn lfun arg) ctxt' args+      ETypeArg { eva_hs_ty = hs_ty, eva_at = at, eva_ty = ty, eva_ctxt = ctxt' }+        -> rebuild_hs_apps (HsAppType ty lfun at hs_ty) ctxt' args       EPrag ctxt' p-        -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args+        -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args       EWrap (EPar ctxt')-        -> rebuildHsApps (gHsPar lfun) ctxt' args+        -> rebuild_hs_apps (gHsPar lfun) ctxt' args       EWrap (EExpand orig)-        -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args+        -> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args       EWrap (EHsWrap wrap)-        -> rebuildHsApps (mkHsWrap wrap fun) ctxt args+        -> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args   where     lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun +{- Note [Checking for representation-polymorphic built-ins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We cannot have representation-polymorphic or levity-polymorphic+function arguments. See Note [Representation polymorphism invariants]+in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in+`tcEValArg`.++But some /built-in/ functions have representation-polymorphic argument+types. Users can't define such Ids; they are all GHC built-ins or data+constructors.  Specifically they are:++1. A few wired-in Ids such as coerce and unsafeCoerce#,+2. Primops, such as raise#.+3. Newtype constructors with `UnliftedNewtypes` which have+   a representation-polymorphic argument.+4. Representation-polymorphic data constructors: unboxed tuples+   and unboxed sums.++For (1) consider+  badId :: forall r (a :: TYPE r). a -> a+  badId = unsafeCoerce# @r @r @a @a++The wired-in function+  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                   (a :: TYPE r1) (b :: TYPE r2).+                   a -> b+has a convenient but representation-polymorphic type. It has no+binding; instead it has a compulsory unfolding, after which we+would have+  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...+And this is no good because of that rep-poly \(x::a).  So we want+to reject this.++On the other hand+  goodId :: forall (a :: Type). a -> a+  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a++is absolutely fine, because after we inline the unfolding, the \(x::a)+is representation-monomorphic.++Test cases: T14561, RepPolyWrappedVar2.++For primops (2) the situation is similar; they are eta-expanded in+CorePrep to be saturated, and that eta-expansion must not add a+representation-polymorphic lambda.++Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.++For (3), consider a representation-polymorphic newtype with+UnliftedNewtypes:++  type Id :: forall r. TYPE r -> TYPE r+  newtype Id a where { MkId :: a }++  bad :: forall r (a :: TYPE r). a -> Id a+  bad = MkId @r @a             -- Want to reject++  good :: forall (a :: Type). a -> Id a+  good = MkId @LiftedRep @a   -- Want to accept++Test cases: T18481, UnliftedNewtypesLevityBinder++So these cases need special treatment. We add a special case+in tcApp to check whether an application of an Id has any remaining+representation-polymorphic arguments, after instantiation and application+of previous arguments.  This is achieved by the tcRemainingValArgs+function, which computes the types of the remaining value arguments, and checks+that each of these have a fixed runtime representation.++Note that this function also ensures that data constructors always+appear saturated, by performing eta-expansion if necessary.+See Note [Typechecking data constructors].++Wrinkle [Arity]++  We don't want to check for arguments past the arity of the function.++  For example++      raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b++  has arity 1, so an instantiation such as:++      foo :: forall w r (z :: TYPE r). w -> z -> z+      foo = raise# @w @(z -> z)++  is unproblematic.  This means we must take care not to perform a+  representation-polymorphism check on `z`.++  To achieve this, we consult the arity of the 'Id' which is the head+  of the application (or just use 1 for a newtype constructor),+  and keep track of how many value-level arguments we have seen,+  to ensure we stop checking once we reach the arity.+  This is slightly complicated by the need to include both visible+  and invisible arguments, as the arity counts both:+  see GHC.Tc.Gen.Head.countVisAndInvisValArgs.++  Test cases: T20330{a,b}++Wrinkle [Syntactic check]++  We only perform a syntactic check in tcRemainingValArgs. That is,+  we will reject partial applications such as:++    type RR :: RuntimeREp+    type family RR where { RR = IntRep }+    type T :: TYPE RR+    type family T where { T = Int# }++    (# , #) @LiftedRep @RR e1++  Why do we reject? Wee would need to elaborate this partial application+  of (# , #) as follows:++    let x1 = e1+    in+      ( \ @(ty2 :: TYPE RR) (x2 :: ty2 |> TYPE RR[0])+      -> ( ( (# , #) @LiftedRep @RR @Char @ty2 x1 ) |> co1 )+           x2+      ) |> co2++  That is, we need to cast the partial application++    (# , #) @LiftedRep @RR @Char @ty2 x1++  so that the next argument we provide to it has a fixed RuntimeRep,+  and then eta-expand it. This is quite tricky, and other parts+  of the compiler aren't set up to handle this mix of applications+  and casts (e.g. checkCanEtaExpand in GHC.Core.Lint).++  So we refrain from doing so, and instead limit ourselves to a simple syntactic+  check. See the wiki page https://gitlab.haskell.org/ghc/ghc/-/wikis/Remaining-ValArgs+  for a more in-depth discussion.+-}++-- | Typecheck the remaining value arguments in a partial application,+-- ensuring they have a fixed RuntimeRep in the sense of Note [Fixed RuntimeRep]+-- in GHC.Tc.Utils.Concrete.+--+-- Example:+--+-- > repPolyId :: forall r (a :: TYPE r). a -> a+-- > repPolyId = coerce+--+-- This is an invalid instantiation of 'coerce', as we can't eta expand it+-- to+--+-- > \@r \@(a :: TYPE r) (x :: a) -> coerce @r @a @a x+--+-- because the binder `x` does not have a fixed runtime representation.+tcRemainingValArgs :: HasDebugCallStack+                   => [HsExprArg 'TcpTc]+                   -> TcRhoType+                   -> HsExpr GhcTc+                   -> TcM ()+tcRemainingValArgs applied_args app_res_rho fun = case fun of++  HsVar _ (L _ fun_id)++    -- (1): unsafeCoerce#+    -- 'unsafeCoerce#' is peculiar: it is patched in manually as per+    -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore.+    -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair,+    -- at this stage, if we query idArity, we get 0. This is because+    -- we end up looking at the non-patched version of unsafeCoerce#+    -- defined in Unsafe.Coerce, and that one indeed has arity 0.+    --+    -- We thus manually specify the correct arity of 1 here.+    | idName fun_id == unsafeCoercePrimName+    -> tc_remaining_args 1 (RepPolyWiredIn fun_id)++    -- (2): primops and other wired-in representation-polymorphic functions,+    -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings+    -- in GHC.Types.Id.Make+    | isWiredInName (idName fun_id) && hasNoBinding fun_id+    -> tc_remaining_args (idArity fun_id) (RepPolyWiredIn fun_id)+       -- NB: idArity consults the IdInfo of the Id. This can be a problem+       -- in the presence of hs-boot files, as we might not have finished+       -- typechecking; inspecting the IdInfo at this point can cause+       -- strange Core Lint errors (see #20447).+       -- We avoid this entirely by only checking wired-in names,+       -- as those are the only ones this check is applicable to anyway.++  XExpr (ConLikeTc (RealDataCon con) _ _)+    -- (3): Representation-polymorphic newtype constructors.+    | isNewDataCon con+    -- (4): Unboxed tuples and unboxed sums+    || isUnboxedTupleDataCon con+    || isUnboxedSumDataCon con+    -> tc_remaining_args (dc_val_arity con) (RepPolyDataCon con)++  _ -> return ()++  where++    dc_val_arity :: DataCon -> Arity+    dc_val_arity con = count (not . isEqPrimPred) (dataConTheta con)+                     + length (dataConStupidTheta con)+                     + dataConSourceArity con+      -- Count how many value-level arguments this data constructor expects:+      --    - dictionary arguments from the context (including the stupid context),+      --    - source value arguments.+      -- Tests: EtaExpandDataCon, EtaExpandStupid{1,2}.++    nb_applied_vis_val_args :: Int+    nb_applied_vis_val_args = count isHsValArg applied_args++    nb_applied_val_args :: Int+    nb_applied_val_args = countVisAndInvisValArgs applied_args++    tc_remaining_args :: Arity -> RepPolyFun -> TcM ()+    tc_remaining_args arity rep_poly_fun =+      tc_rem_args+        (nb_applied_vis_val_args + 1)+        (nb_applied_val_args + 1)+        rem_arg_tys++      where++      rem_arg_tys :: [(Scaled Type, AnonArgFlag)]+      rem_arg_tys = getRuntimeArgTys app_res_rho+        -- We do not need to zonk app_res_rho first, because the number of arrows+        -- in the (possibly instantiated) inferred type of the function will+        -- be at least the arity of the function.++      -- The following function is essentially "mapM hasFixedRuntimeRep rem_arg_tys",+      -- but we need to keep track of indices for error messages, hence the manual recursion.+      tc_rem_args :: Int+                     -- visible value argument index, starting from 1+                     -- (only used to report the argument position in error messages)+                  -> Int+                     -- value argument index, starting from 1+                     -- used to count up to the arity to ensure that+                     -- we don't check too many argument types+                  -> [(Scaled Type, AnonArgFlag)]+                     -- run-time argument types+                  -> TcM ()+      tc_rem_args _ i_val _+        | i_val > arity+        = return ()+      tc_rem_args _ _ []+        -- Should never happen: it would mean that the arity is higher+        -- than the number of arguments apparent from the type.+        = pprPanic "tcRemainingValArgs" debug_msg+      tc_rem_args i_visval !i_val ((Scaled _ arg_ty, af) : tys)+        = do { let (i_visval', arg_pos) =+                     case af of { InvisArg -> ( i_visval    , ArgPosInvis )+                                ; VisArg   -> ( i_visval + 1, ArgPosVis i_visval ) }+                   frr_ctxt = FRRNoBindingResArg rep_poly_fun arg_pos+             ; hasFixedRuntimeRep_syntactic frr_ctxt arg_ty+                 -- Why is this a syntactic check? See Wrinkle [Syntactic check] in+                 -- Note [Checking for representation-polymorphic built-ins].+             ; tc_rem_args i_visval' (i_val + 1) tys }++      debug_msg :: SDoc+      debug_msg =+        vcat+          [ text "app_head =" <+> ppr fun+          , text "arity =" <+> ppr arity+          , text "applied_args =" <+> ppr applied_args+          , text "nb_applied_val_args =" <+> ppr nb_applied_val_args ]++ isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True isHsValArg _            = False@@ -482,7 +777,7 @@       HsRecSel _ f              -> Just <$> tcInferRecSelId f       ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit-      HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))+      HsUntypedSplice (HsUntypedSpliceTop _ e) _                                 -> tcInferAppHead_maybe e args       _                         -> return Nothing @@ -845,8 +1140,11 @@         ; let full_theta  = stupid_theta ++ theta              all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys-                -- stupid-theta must come first+                -- We are building the type of the data con wrapper, so the+                -- type must precisely match the construction in+                -- GHC.Core.DataCon.dataConWrapperType.                 -- See Note [Instantiating stupid theta]+                -- in GHC.Core.DataCon.         ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)                 , mkInvisForAllTys tvbs $ mkPhiTy full_theta $@@ -868,22 +1166,31 @@ nonBidirectionalErr :: Name -> TcRnMessage nonBidirectionalErr = TcRnPatSynNotBidirectional -{- Note [Typechecking data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Adding the implicit parameter to 'assert']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker transforms (assert e1 e2) to (assertError e1 e2).+This isn't really the Right Thing because there's no way to "undo"+if you want to see the original source code in the typechecker+output.  We'll have fix this in due course, when we care more about+being able to reconstruct the exact original program.++Note [Typechecking data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As per Note [Polymorphisation of linear fields] in GHC.Core.Multiplicity, linear fields of data constructors get a polymorphic multiplicity when the data constructor is used as a term:      Just :: forall {p} a. a %p -> Maybe a -So at an occurrence of a data constructor we do the following,-mostly in tcInferDataCon:+So at an occurrence of a data constructor we do the following: -1. Get its type, say-    K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a-   Note the %1: it is linear+1. Typechecking, in tcInferDataCon. -2. We are going to return a ConLikeTc, thus:+  a. Get the original type of the constructor, say+     K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a+     Note the %1: it is linear++  b. We are going to return a ConLikeTc, thus:      XExpr (ConLikeTc K [r,a] [Scaled p a])       :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a    where 'p' is a fresh multiplicity unification variable.@@ -893,93 +1200,71 @@    the fresh multiplicity variable in the ConLikeTc; along with    the type of the ConLikeTc. This is done by linear_to_poly. -3. If the argument is not linear (perhaps explicitly declared as+   If the argument is not linear (perhaps explicitly declared as    non-linear by the user), don't bother with this. -4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by-   GHC.HsToCore.Expr.dsConLike to:+2. Desugaring, in dsConLike.++  a. The (ConLikeTc K [r,a] [Scaled p a]) is desugared to      (/\r (a :: TYPE r). \(x %p :: a). K @r @a x)    which has the desired type given in the previous bullet.+    The 'p' is the multiplicity unification variable, which    will by now have been unified to something, or defaulted in    `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an    (unbound) variable. -Wrinkles--* Note that the [TcType] is strictly redundant anyway; those are the-  type variables from the dataConUserTyVarBinders of the data constructor.-  Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly-  from the data constructor.  The only bit that /isn't/ redundant is the-  fresh multiplicity variables!--  So an alternative would be to define ConLikeTc like this:-      | ConLikeTc [TcType]    -- Just the multiplicity variables-  But then the desugarer would need to repeat some of the work done here.-  So for now at least ConLikeTc records this strictly-redundant info.--* The lambda expression we produce in (4) can have representation-polymorphic-  arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),-  we have a lambda-bound variable x :: (a :: TYPE r).-  This goes against the representation polymorphism invariants given in-  Note [Representation polymorphism invariants] in GHC.Core. The trick is that-  this this lambda will always be instantiated in a way that upholds the invariants.-  This is achieved as follows:--    A. Any arguments to such lambda abstractions are guaranteed to have-       a fixed runtime representation. This is enforced in 'tcApp' by-       'matchActualFunTySigma'.--    B. If there are fewer arguments than there are bound term variables,-       hasFixedRuntimeRep_remainingValArgs will ensure that we are still-       instantiating at a representation-monomorphic type, e.g.--       ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#-         :: Int# -> T IntRep Int#--  We then rely on the simple optimiser to beta reduce the lambda.--* See Note [Instantiating stupid theta] for an extra wrinkle+   So a saturated application (K e), where e::Int will desugar to+     (/\r (a :: TYPE r). ..etc..)+        @LiftedRep @Int e+   and all those lambdas will beta-reduce away in the simple optimiser+   (see Wrinkle [Representation-polymorphic lambdas] below). +   But for an /unsaturated/ application, such as `map (K @LiftedRep @Int) xs`,+   beta reduction will leave (\x %Many :: Int. K x), which is the type `map`+   expects whereas if we had just plain K, with its linear type, we'd+   get a type mismatch. That's why we do this funky desugaring. -Note [Adding the implicit parameter to 'assert']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The typechecker transforms (assert e1 e2) to (assertError e1 e2).-This isn't really the Right Thing because there's no way to "undo"-if you want to see the original source code in the typechecker-output.  We'll have fix this in due course, when we care more about-being able to reconstruct the exact original program.+Wrinkles +  [ConLikeTc arguments] -Note [Instantiating stupid theta]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a data type with a "stupid theta" (see-Note [The stupid context] in GHC.Core.DataCon):+    Note that the [TcType] argument to ConLikeTc is strictly redundant; those are+    the type variables from the dataConUserTyVarBinders of the data constructor.+    Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly+    from the data constructor.  The only bit that /isn't/ redundant is the+    fresh multiplicity variables! -  data Ord a => T a = MkT (Maybe a)+    So an alternative would be to define ConLikeTc like this:+        | ConLikeTc [TcType]    -- Just the multiplicity variables+    But then the desugarer would need to repeat some of the work done here.+    So for now at least ConLikeTc records this strictly-redundant info. -We want to generate an Ord constraint for every use of MkT; but-we also want to allow visible type application, such as-   MkT @Int+  [Representation-polymorphic lambdas] -So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type-   forall a. Ord a => Maybe a -> T a+    The lambda expression we produce in (4) can have representation-polymorphic+    arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),+    we have a lambda-bound variable x :: (a :: TYPE r).+    This goes against the representation polymorphism invariants given in+    Note [Representation polymorphism invariants] in GHC.Core. The trick is that+    this this lambda will always be instantiated in a way that upholds the invariants.+    This is achieved as follows: -Now visible type application will work fine. But we desugar the-ConLikeTc to-   /\a \(d:Ord a) (x:Maybe a). MkT x-Notice that 'd' is dropped in this desugaring. We don't need it;-it was only there to generate a Wanted constraint. (That is why-it is stupid.)  To achieve this:+      A. Any arguments to such lambda abstractions are guaranteed to have+         a fixed runtime representation. This is enforced in 'tcApp' by+         'matchActualFunTySigma'. -* We put the stupid-thata at the front of the list of argument-  types in ConLikeTc+      B. If there are fewer arguments than there are bound term variables,+         hasFixedRuntimeRep_remainingValArgs will ensure that we are still+         instantiating at a representation-monomorphic type, e.g. -* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the-  arguments, but drops the stupid-theta arguments when building the-  /application/.+         ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#+           :: Int# -> T IntRep Int# -Nice.+      C. In the output of the desugarer in (4) above, we have a representation+         polymorphic lambda, which Lint would normally reject. So for that one+         pass, we switch off Lint's representation-polymorphism checks; see+         the `lf_check_fixed_rep` flag in `LintFlags`. -}  {-
compiler/GHC/Tc/Gen/HsType.hs view
@@ -96,7 +96,8 @@ import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,-                                  tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs )+                                  tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs,+                                  tcInstTypeBndrs ) import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Error@@ -1042,9 +1043,11 @@ -- splices or not. -- -- See Note [Delaying modFinalizers in untyped splices].-tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))+tc_infer_hs_type mode (HsSpliceTy (HsUntypedSpliceTop _ ty) _)   = tc_infer_hs_type mode ty +tc_infer_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) = pprPanic "tc_infer_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)+ tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty  -- See Note [Typechecking HsCoreTys]@@ -1142,14 +1145,12 @@ -- while capturing the local environment. -- -- See Note [Delaying modFinalizers in untyped splices].-tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))+tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _)            exp_kind   = do addModFinalizersWithLclEnv mod_finalizers        tc_hs_type mode ty exp_kind --- This should never happen; type splices are expanded by the renamer-tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind-  = failWithTc $ TcRnUnexpectedTypeSplice ty+tc_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tc_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)  ---------- Functions and applications tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind@@ -3975,12 +3976,13 @@        -- See Note [Extra-constraint holes in partial type signatures]        ; mapM_ emitNamedTypeHole wcs -       -- Zonk, so that any nested foralls can "see" their occurrences-       -- See Note [Checking partial type signatures], and in particular-       -- Note [Levels for wildcards]-       ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs-       ; theta          <- mapM zonkTcType theta-       ; tau            <- zonkTcType tau+         -- The "tau" from tcHsPartialSigType might very well have some foralls+         -- at the top, hidden behind a type synonym. Instantiate them! E.g.+         --    type T x = forall b. x -> b -> b+         --    f :: forall a. T (a,_)+         -- We must instantiate the `forall b` just as we do the `forall a`!+         -- Missing this led to #21667.+       ; (tv_prs', theta', tau) <- tcInstTypeBndrs tau           -- We return a proper (Name,InvisTVBinder) environment, to be sure that          -- we bring the right name into scope in the function body.@@ -3990,6 +3992,13 @@              tv_prs :: [(Name,InvisTVBinder)]              tv_prs = outer_bndr_names `zip` outer_tv_bndrs +       -- Zonk, so that any nested foralls can "see" their occurrences+       -- See Note [Checking partial type signatures], and in particular+       -- Note [Levels for wildcards]+       ; tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs')+       ; theta  <- mapM    zonkTcType        (theta ++ theta')+       ; tau    <- zonkTcType                tau+       -- NB: checkValidType on the final inferred type will be       --     done later by checkInferredPolyId.  We can't do it       --     here because we don't have a complete type to check@@ -4042,7 +4051,7 @@   source-code LHsSigWcType  * Then, for f and g /separately/, we call tcInstSig, which in turn-  call tchsPartialSig (defined near this Note).  It kind-checks the+  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   because they might get instantiated completely differently.  E.g.
compiler/GHC/Tc/Gen/Match.hs view
@@ -71,7 +71,6 @@ import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) -import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id@@ -79,6 +78,7 @@  import Control.Monad import Control.Arrow ( second )+import qualified Data.List.NonEmpty as NE  {- ************************************************************************@@ -1143,32 +1143,28 @@  checkArgCounts :: AnnoBody body                => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()-checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr+checkArgCounts = check_match_pats . EquationArgs  -- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same -- number of patterns are used in each alternative checkPatCounts :: AnnoBody body                => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))                -> TcM ()-checkPatCounts = check_match_pats . pprMatchContextNouns+checkPatCounts = check_match_pats . PatternArgs  check_match_pats :: AnnoBody body-                 => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn))+                 => MatchArgsContext -> MatchGroup GhcRn (LocatedA (body GhcRn))                  -> TcM () check_match_pats _ (MG { mg_alts = L _ [] })     = return ()-check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) })-    | null bad_matches-    = return ()+check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) })+    | Just bad_matches <- mb_bad_matches+    = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext match1 bad_matches     | otherwise-    = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-      (vcat [ err_msg <+>-              text "have different numbers of arguments"-            , nest 2 (ppr (getLocA match1))-            , nest 2 (ppr (getLocA (head bad_matches)))])+    = return ()   where     n_args1 = args_in_match match1-    bad_matches = [m | m <- matches, args_in_match m /= n_args1]+    mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1]      args_in_match :: (LocatedA (Match GhcRn body1) -> Int)     args_in_match (L _ (Match { m_pats = pats })) = length pats
compiler/GHC/Tc/Gen/Pat.hs view
@@ -71,6 +71,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Arrow  ( second ) import Control.Monad+import qualified Data.List.NonEmpty as NE import GHC.Data.List.SetOps ( getNth )  {-@@ -402,7 +403,7 @@         ; pat_ty <- expTypeToType (scaledThing pat_ty)         ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } -  AsPat x (L nm_loc name) pat -> do+  AsPat x (L nm_loc name) at pat -> do         { mult_wrap <- checkManyPattern pat_ty             -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.         ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)@@ -417,7 +418,7 @@             --             -- If you fix it, don't forget the bindInstsOfPatIds!         ; pat_ty <- readExpType (scaledThing pat_ty)-        ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) }+        ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) at pat') pat_ty, res) }    ViewPat _ expr pat -> do         { mult_wrap <- checkManyPattern pat_ty@@ -685,16 +686,14 @@                                ge' minus''         ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) } --- 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 GHC.Rename.Splice.-  SplicePat _ splice -> case splice of-    (HsSpliced _ mod_finalizers (HsSplicedPat pat)) -> do+  SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do       { addModFinalizersWithLclEnv mod_finalizers       ; tc_pat pat_ty penv pat thing_inside }-    _ -> panic "invalid splice in splice pat" +  SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"+   XPat (HsPatExpanded lpat rpat) -> do     { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside     ; return (XPat $ ExpansionPat lpat rpat', res) }@@ -745,26 +744,29 @@         -- and not already in scope. These are the ones         -- that should be brought into scope -        ; if null sig_tvs then do {+        ; case NE.nonEmpty sig_tvs of+            Nothing -> do {                 -- Just do the subsumption check and return                   wrap <- addErrCtxtM (mk_msg sig_ty) $                           tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty                 ; return (sig_ty, [], sig_wcs, wrap)-        } else do+                }+            Just sig_tvs_ne -> do                 -- Type signature binds at least one scoped type variable                  -- A pattern binding cannot bind scoped type variables                 -- It is more convenient to make the test here                 -- than in the renamer-        { when in_pat_bind (addErr (patBindSigErr sig_tvs))+              when in_pat_bind+                (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) -        -- Now do a subsumption check of the pattern signature against res_ty-        ; wrap <- addErrCtxtM (mk_msg sig_ty) $-                  tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty+              -- Now do a subsumption check of the pattern signature against res_ty+              wrap <- addErrCtxtM (mk_msg sig_ty) $+                      tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty -        -- Phew!-        ; return (sig_ty, sig_tvs, sig_wcs, wrap)-        } }+              -- Phew!+              return (sig_ty, sig_tvs, sig_wcs, wrap)+       }   where     mk_msg sig_ty tidy_env        = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty@@ -776,14 +778,7 @@                                           2 (ppr res_ty)) ]             ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage-patBindSigErr sig_tvs-  = TcRnUnknownMessage $ mkPlainError noHints $-    hang (text "You cannot bind scoped type variable" <> plural sig_tvs-          <+> pprQuotedList (map fst sig_tvs))-       2 (text "in a pattern binding signature") - {- ********************************************************************* *                                                                      *         Most of the work for constructors is here@@ -935,7 +930,7 @@         ; zipWithM_             ( \ i arg_sty ->               hasFixedRuntimeRep_syntactic-                (FRRDataConArg Pattern data_con i)+                (FRRDataConPatArg data_con i)                 (scaledThing arg_sty)             )             [1..]@@ -1255,7 +1250,7 @@         ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $                                  conLikeUserTyVarBinders con_like         ; checkTc (type_args `leLength` con_spec_binders)-                  (conTyArgArityErr con_like (length con_spec_binders) (length type_args))+                  (TcRnTooManyTyArgsInConPattern con_like (length con_spec_binders) (length type_args))          ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys         ; (type_args', (arg_pats', res))@@ -1325,8 +1320,8 @@           -- dataConFieldLabels will be empty (and each field in the pattern           -- will generate an error below). -tcConTyArg :: Checker (HsPatSigType GhcRn) TcType-tcConTyArg penv rn_ty thing_inside+tcConTyArg :: Checker (HsConPatTyArg GhcRn) TcType+tcConTyArg penv (HsConPatTyArg _ rn_ty) thing_inside   = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsPatSigType TypeAppCtxt HM_TyAppPat rn_ty AnyKind                -- AnyKind is a bit suspect: it really should be the kind gotten                -- from instantiating the constructor type. But this would be@@ -1334,9 +1329,10 @@                -- the kinds of later patterns. In any case, it all gets checked                -- by the calls to unifyType in tcConArgs, which will also unify                -- kinds.-       ; when (not (null sig_ibs) && inPatBind penv) $-           addErr (TcRnUnknownMessage $ mkPlainError noHints $-                     text "Binding type variables is not allowed in pattern bindings")+       ; case NE.nonEmpty sig_ibs of+           Just sig_ibs_ne | inPatBind penv ->+             addErr (TcRnCannotBindTyVarsInPatBind sig_ibs_ne)+           _ -> pure ()        ; result <- tcExtendNameTyVarEnv sig_wcs $                    tcExtendNameTyVarEnv sig_ibs $                    thing_inside@@ -1363,15 +1359,6 @@          -- NB: inst_tys can be longer than the univ tyvars          --     because the constructor might have existentials     inst_theta = substTheta tenv stupid_theta--conTyArgArityErr :: ConLike-                 -> Int   -- expected # of arguments-                 -> Int   -- actual # of arguments-                 -> TcRnMessage-conTyArgArityErr con_like expected_number actual_number-  = TcRnUnknownMessage $ mkPlainError noHints $-    text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$-    text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number  {- Note [Arrows and patterns]
compiler/GHC/Tc/Gen/Sig.hs view
@@ -68,9 +68,10 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.Maybe( orElse )+import GHC.Data.Maybe( orElse, whenIsJust )  import Data.Maybe( mapMaybe )+import qualified Data.List.NonEmpty as NE import Control.Monad( unless )  @@ -315,8 +316,8 @@                                         && go ty       HsQualTy { hst_ctxt = ctxt                , hst_body = ty }  -> gos (unLoc ctxt) && go ty-      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty-      HsSpliceTy{} -> True+      HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go $ L noSrcSpanA ty+      HsSpliceTy (HsUntypedSpliceNested _) _ -> True       HsTyLit{} -> True       HsTyVar{} -> True       HsStarTy{} -> True@@ -504,7 +505,7 @@ -- Instantiate a type signature; only used with plan InferGen tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })   = setSrcSpan loc $  -- Set the binding site of the tyvars-    do { (tv_prs, theta, tau) <- tcInstTypeBndrs poly_id+    do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id)               -- See Note [Pattern bindings and complete signatures]         ; return (TISI { sig_inst_sig   = sig@@ -521,6 +522,7 @@     do { traceTc "Staring partial sig {" (ppr hs_sig)        ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty          -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType+        ; let inst_sig = TISI { sig_inst_sig   = hs_sig                              , sig_inst_skols = tv_prs                              , sig_inst_wcs   = wcs@@ -631,16 +633,10 @@          warn_multiple_inlines inl2 inls        | otherwise        = setSrcSpanA loc $-         let dia = TcRnUnknownMessage $-               mkPlainDiagnostic WarningWithoutFlag noHints $-                 (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)-                   2 (vcat (text "Ignoring all but the first"-                            : map pp_inl (inl1:inl2:inls))))+         let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls)          in addDiagnosticTc dia -    pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - {- Note [Pattern synonym inline arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -776,7 +772,7 @@ -- Reason: required by tcSubExp tcSpecPrags poly_id prag_sigs   = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)-       ; unless (null bad_sigs) warn_discarded_sigs+       ; whenIsJust (NE.nonEmpty bad_sigs) warn_discarded_sigs        ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs        ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss }   where@@ -784,11 +780,8 @@     bad_sigs  = filter is_bad_sig prag_sigs     is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) -    warn_discarded_sigs-      = let dia = TcRnUnknownMessage $-              mkPlainDiagnostic WarningWithoutFlag noHints $-                (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)-                    2 (vcat (map (ppr . getLoc) bad_sigs)))+    warn_discarded_sigs bad_sigs_ne+      = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne         in addDiagnosticTc dia  --------------@@ -803,9 +796,7 @@ -- what the user wrote (#8537)   = addErrCtxt (spec_ctxt prag) $     do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $-                 TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints-                   (text "SPECIALISE pragma for non-overloaded function"-                    <+> quotes (ppr fun_name))+                 TcRnNonOverloadedSpecialisePragma fun_name                     -- Note [SPECIALISE pragmas]         ; spec_prags <- mapM tc_one hs_tys         ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))@@ -867,20 +858,9 @@       ; if hasSomeUnfolding (realIdUnfolding id)            -- See Note [SPECIALISE pragmas for imported Ids]         then tcSpecPrag id prag-        else do { let dia = TcRnUnknownMessage $-                        mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name)+        else do { let dia = TcRnSpecialiseNotVisible name                 ; addDiagnosticTc dia                 ; return [] } }--impSpecErr :: Name -> SDoc-impSpecErr name-  = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))-       2 (vcat [ text "because its definition is not visible in this module"-               , text "Hint: make sure" <+> ppr mod <+> text "is compiled with -O"-               , text "      and that" <+> quotes (ppr name)-                 <+> text "has an INLINABLE pragma" ])-  where-    mod = nameModule name  {- Note [SPECIALISE pragmas for imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Gen/Splice.hs view
@@ -20,9 +20,7 @@  -- | Template Haskell splices module GHC.Tc.Gen.Splice(-     tcSpliceExpr, tcTypedBracket, tcUntypedBracket,---     runQuasiQuoteExpr, runQuasiQuotePat,---     runQuasiQuoteDecl, runQuasiQuoteType,+     tcTypedSplice, tcTypedBracket, tcUntypedBracket,      runAnnotation,       runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,@@ -120,6 +118,7 @@ import GHC.Unit.Module.Deps  import GHC.Utils.Misc+import GHC.Utils.Trace import GHC.Utils.Panic as Panic import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme@@ -160,7 +159,480 @@ import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) ++ {-+Note [Template Haskell state diagram]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the ThStages, s, their corresponding level numbers+(the result of (thLevel s)), and their state transitions.+The top level of the program is stage Comp:++     Start here+         |+         V+      -----------     $      ------------   $+      |  Comp   | ---------> |  Splice  | -----|+      |   1     |            |    0     | <----|+      -----------            ------------+        ^     |                ^      |+      $ |     | [||]         $ |      | [||]+        |     v                |      v+   --------------          ----------------+   | Brack Comp |          | Brack Splice |+   |     2      |          |      1       |+   --------------          ----------------++* Normal top-level declarations start in state Comp+       (which has level 1).+  Annotations start in state Splice, since they are+       treated very like a splice (only without a '$')++* Code compiled in state Splice (and only such code)+  will be *run at compile time*, with the result replacing+  the splice++* The original paper used level -1 instead of 0, etc.++* The original paper did not allow a splice within a+  splice, but there is no reason not to. This is the+  $ transition in the top right.++Note [Template Haskell levels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Imported things are impLevel (= 0)++* However things at level 0 are not *necessarily* imported.+      eg  $( \b -> ... )   here b is bound at level 0++* In GHCi, variables bound by a previous command are treated+  as impLevel, because we have bytecode for them.++* Variables are bound at the "current level"++* The current level starts off at outerLevel (= 1)++* The level is decremented by splicing $(..)+               incremented by brackets [| |]+               incremented by name-quoting 'f++* When a variable is used, checkWellStaged compares+        bind:  binding level, and+        use:   current level at usage site++  Generally+        bind > use      Always error (bound later than used)+                        [| \x -> $(f x) |]++        bind = use      Always OK (bound same stage as used)+                        [| \x -> $(f [| x |]) |]++        bind < use      Inside brackets, it depends+                        Inside splice, OK+                        Inside neither, OK++  For (bind < use) inside brackets, there are three cases:+    - Imported things   OK      f = [| map |]+    - Top-level things  OK      g = [| f |]+    - Non-top-level     Only if there is a liftable instance+                                h = \(x:Int) -> [| x |]++  To track top-level-ness we use the ThBindEnv in TcLclEnv++  For example:+           f = ...+           g1 = $(map ...)         is OK+           g2 = $(f ...)           is not OK; because we haven't compiled f yet+++Note [How top-level splices are handled]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level splices (those not inside a [| .. |] quotation bracket) are handled+very straightforwardly:++  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)++  2. runMetaT: desugar, compile, run it, and convert result back to+     GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName,+     HsExpr RdrName etc)++  3. treat the result as if that's what you saw in the first place+     e.g for HsType, rename and kind-check+         for HsExpr, rename and type-check++     (The last step is different for decls, because they can *only* be+      top-level: we return the result of step 2.)++Note [Warnings for TH splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only produce warnings for TH splices when the user requests so+(-fenable-th-splice-warnings). There are multiple reasons:++  * It's not clear that the user that compiles a splice is the author of the code+    that produces the warning. Think of the situation where they just splice in+    code from a third-party library that produces incomplete pattern matches.+    In this scenario, the user isn't even able to fix that warning.+  * Gathering information for producing the warnings (pattern-match check+    warnings in particular) is costly. There's no point in doing so if the user+    is not interested in those warnings.++That's why we store Origin flags in the Haskell AST. The functions from ThToHs+take such a flag and depending on whether TH splice warnings were enabled or+not, we pass FromSource (if the user requests warnings) or Generated+(otherwise). This is implemented in getThSpliceOrigin.++For correct pattern-match warnings it's crucial that we annotate the Origin+consistently (#17270). In the future we could offer the Origin as part of the+TH AST. That would enable us to give quotes from the current module get+FromSource origin, and/or third library authors to tag certain parts of+generated code as FromSource to enable warnings.+That effort is tracked in #14838.++Note [The life cycle of a TH quotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When desugaring a bracket (aka quotation), we want to produce Core+code that, when run, will produce the TH syntax tree for the quotation.+To that end, we want to desugar /renamed/ but not /typechecked/ code;+the latter is cluttered with the typechecker's elaboration that should+not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must+have a (HsExpr GhcRn) for the quotation itself.++As such, when typechecking both typed and untyped brackets,+we keep a /renamed/ bracket in the extension field.++The HsBracketTc, the GhcTc ext field for both typed and untyped+brackets, contains:+  - The renamed quote :: HsQuote GhcRn -- for the desugarer+  - [PendingTcSplice]+  - The type of the quote+  - Maybe QuoteWrapper++Note that HsBracketTc stores the untyped (HsQuote GhcRn) for both typed and+untyped brackets. They are treated uniformly by the desugarer, and we can+easily construct untyped brackets from typed ones (with ExpBr).++See Note [Desugaring of brackets].++------------+Typed quotes+------------+Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is+  HsTypedBracket (XTypedBracket p) (LHsExpr p)++  In pass p   (XTypedBracket p)       (LHsExpr p)+  -------------------------------------------+  GhcPs       Annotations only        LHsExpr GhcPs+  GhcRn       Annotations only        LHsExpr GhcRn+  GhcTc       HsBracketTc             LHsExpr GhcTc: unused!++Note that in the GhcTc tree, the second field (HsExpr GhcTc)+is entirely unused; the desugarer uses the (HsExpr GhcRn) from the+first field.++--------------+Untyped quotes+--------------+Here is the life cycle of an /untyped/ quote, whose datacon is+   HsUntypedBracket (XUntypedBracket p) (HsQuote p)++Here HsQuote is a sum-type of expressions [| e |], patterns [| p |],+types [| t |] etc.++  In pass p   (XUntypedBracket p)          (HsQuote p)+  -------------------------------------------------------+  GhcPs   Annotations only                 HsQuote GhcPs+  GhcRn   Annotations, [PendingRnSplice]   HsQuote GhcRn+  GhcTc   HsBracketTc                      HsQuote GhcTc: unused!++The difficulty is: the typechecker does not typecheck the body of an+untyped quote, so how do we make a (HsQuote GhcTc) to put in the+second field?++Answer: we use the extension constructor of HsQuote, namely XQuote,+and make all the other constructors into DataConCantHappen.  That is,+the only non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField).+Hence the instances++  type instance XExpBr GhcTc = DataConCantHappen+  ...etc...++See the related Note [How brackets and nested splices are handled]++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`.+Note carefully that this is overloaded: its type is not `Q Exp` for some fixed Q.++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 GHC.HsToCore.Quote)++`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.++Note [Lifecycle of an untyped splice, and PendingRnSplice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Untyped splices $(f x) and quasiquotes [p| stuff |] have the following+life cycle. Remember, quasi-quotes are very like splices; see Note [Quasi-quote overview]).++The type structure is++  data HsExpr p = ...+    | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p)++  data HsUntypedSplice p+    = HsUntypedSpliceExpr (XUntypedSpliceExpr p) (LHsExpr p)+    | HsQuasiQuote (XQuasiQuote p) (IdP id) (XRec p FastString)++Remember that untyped splices can occur in expressions, patterns,+types, and declarations.  So we have a HsUntypedSplice data+constructor in all four of these types.++Untyped splices never occur in (HsExpr GhcTc), and similarly+patterns etc. So we have++   type instance XUntypedSplice GhcTc = DataConCantHappen++Top-level and nested splices are handled differently.++-------------------------------------+Nested untyped splices/quasiquotes+----------------------------------+When we rename an /untyped/ bracket, such as+     [| f $(g x) |]+we name and lift out all the nested splices, so that when the+typechecker hits the bracket, it can typecheck those nested splices+without having to walk over the untyped bracket code.  Our example+[| f $(g x) |] parses as++    HsUntypedBracket _+       (HsApp (HsVar "f")+              (HsUntypedSplice _ (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcPs)))++RENAMER (rnUntypedBracket):++* Set the ThStage to (Brack s (RnPendingUntyped ps_var))++* Rename the body++* Nested splices (which must be untyped) are renamed (rnUntypedSplice),+  and the results accumulated in ps_var. Each gets a fresh+  SplicePointName, 'spn'++* The SplicePointName connects the `PendingRnSplice` with the particular point+  in the syntax tree where that expresion should be spliced in.  That point+  in the tree is identified by `(HsUntypedSpliceNested spn)`.  It is used by+  the desugarer, so that we ultimately generate something like+       let spn = g x+       in App (Var "f") spn++The result is+    HsUntypedBracket+        [PendingRnSplice UntypedExpSplice spn (g x  :: LHsExpr GHcRn)]+        (HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn)+                                          (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))))++Note that a nested splice, such as the `$(g x)` now appears twice:+  - In the PendingRnSplice: this is the version that will later be typechecked+  - In the HsUntypedSpliceExpr in the body of the bracket. This copy is used+    only for pretty printing.++NB: a single untyped bracket can contain many splices, each of a different+`UntypedSpliceFlavour`. For example++   [| let $e0 in (f :: $e1) $e2 (\ $e -> body ) |] + 1++Here $e0 is a declaration splice, $e1 is a type splice, $e2 is an+expression splice, and $e3 is a pattern splice.  The `PendingRnSplice`+keeps track of which is which through its `UntypedSpliceFlavour`+field.++TYPECHECKER (tcUntypedBracket): see also Note [Typechecking Overloaded Quotes]++* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice]+  So PendingTcSplice is used for both typed and untyped splices.++* Ignore the body of the bracket; just check that the context+  expects a bracket of that type (e.g. a [p| pat |] bracket should+  be in a context needing a (m Pat)++* Stash the whole lot inside a HsBracketTc++Result is:+    HsUntypedBracket+        (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x  :: LHsExpr GHcTc)]+                     , hsb_quote = HsApp (HsVar f)+                                         (HsUntypedSplice (HsUntypedSpliceNested spn)+                                            (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn)))+                     })+        (XQuote noExtField)++NB in the typechecker output, the original payload (which would now+have type (HsQuote GhcTc) is stubbed off with (XQuote noExtField). The payload+is now in the hsb_quote field of the HsBracketTc.+++-------------------------------------+Top-level untyped splices/quasiquotes+-------------------------------------+A top-level splice (not inside a bracket) does not need a SpliceName,+nor does a top-level splice ever end up inside a PendingRnSplice;+hence HsUntypedSpliceTop does not have a SplicePointName field.++Example $(g x).  This is parsed as++  HsUntypedSplice _ (HsUntypedSpliceExpr _ ((g x) :: LHsExpr GhcPs))++Renamer: the renamer runs the splice, so the output of the renamer looks like++  HsUntypedSplice (HsUntypedSpliceTop fins (e2 :: LHsExpr GhcRn))+                  (HsUntypedSpliceExpr ((g x) :: LHsExpr GhcRn))++where 'e2' is the result of running (g x) to+             produce the syntax tree for 'e2'+      'fins' is a bunch of TH finalisers, to be run later.++Typechecker: the typechecker simply adds the finalisers, and+typechecks e2, discarding the HsUntypedSplice altogether.+++Note [Lifecycle of an typed splice, and PendingTcSplice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++----------------------+Nested, typed splices+----------------------+When we typecheck a /typed/ bracket, we lift nested splices out as+`PendingTcSplice`, very similar to Note [PendingRnSplice]. Again, the+splice needs a SplicePointName, for the desguarer to use to connect+the splice expression with the point in the syntax tree where it is+used.  Example:+     [||  f $$(g 2)||]++Parser: this is parsed as++    HsTypedBracket _ (HsApp (HsVar "f")+                            (HsTypedSplice _ (g 2 :: LHsExpr GhcPs)))++RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn:++    HsTypedBracket _ (HsApp (HsVar "f")+                            (HsTypedSplice spn (g x :: LHsExpr GhcRn)))++TYPECHECKER (tcTypedBracket):++* Set the ThStage to (Brack s (TcPending ps_var lie_var))++* Typecheck the body, and keep the elaborated result (despite never using it!)++* Nested splices (which must be typed) are typechecked by tcNestedSplice, and+  the results accumulated in ps_var; their constraints accumulate in lie_var++* Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack+  where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn++Just like untyped brackets, dump the output into a HsBracketTc.++    HsTypedBracket+        (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x  :: LHsExpr GHcTc)]+                     , hsb_quote = HsApp (HsVar f)+                                         (HsUntypedSplice (HsUntypedSpliceNested spn)+                                            (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn)))+                     })+        (panic "should never be looked at")++NB: we never need to represent typed /nested/ splices in phase GhcTc.++There are only typed expression splices so `PendingTcSplice` doesn't have a+flavour field.+++--------------------------------+Top-level, typed splices $$(f x)+--------------------------------+Typed splices are renamed and typechecked, but only actually run in+the zonker, after typechecking. See Note [Running typed splices in the zonker]++* Output of parser:+  HsTypedSplice _ (e :: HsExpr GhcPs)++* Output of renamer:+  HsTypedSplice (n :: SplicePointName) (e :: HsExpr GhcRn)++* Output of typechecker: (top-level splices only)+  HsTypedSplice (del_splice :: DelayedSplice) (e :: HsExpr GhcTc)+  where 'del_splice' is something the zonker can run to produce+           the syntax tree to splice in.+           See Note [Running typed splices in the zonker]++Note [Desugaring of brackets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In both cases, desugaring happens like this:+  * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed+    expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It++      a) Extends the ds_meta environment with the PendingSplices+         attached to the bracket++      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when+         run, will produce a suitable TH expression/type/decl.  This+         is why we leave the *renamed* expression attached to the bracket:+         the quoted expression should not be decorated with all the goop+         added by the type checker++  * Each splice carries a unique Name, called a "splice point", thus+    ${n}(e).  The name is initialised to an (Unqual "splice") when the+    splice is created; the renamer gives it a unique.++  * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across+    a splice, it looks up the splice's Name, n, in the ds_meta envt,+    to find an (HsExpr Id) that should be substituted for the splice;+    it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice).++Example:+    Source:       f = [| Just $(g 3) |]+      The [| |] part is a HsUntypedBracket GhcPs++    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}+      The [| |] part is a HsUntypedBracket GhcTc, containing *renamed*+        (not typechecked) expression (see Note [The life cycle of a TH quotation])+      The "s7" is the "splice point"; the (g Int 3) part+        is a typechecked expression++    Desugared:    f = do { s7 <- g Int 3+                         ; return (ConE "Data.Maybe.Just" s7) }++-}++{- ************************************************************************ *                                                                      * \subsection{Main interface + stubs for the non-GHCI case@@ -168,17 +640,12 @@ ************************************************************************ -} -tcTypedBracket   :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType-                 -> TcM (HsExpr GhcTc)-tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTc)+tcTypedBracket    :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcUntypedBracket  :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType+                  -> TcM (HsExpr GhcTc)+tcTypedSplice :: Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)         -- None of these functions add constraints to the LIE --- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)--- runQuasiQuotePat  :: HsQuasiQuote RdrName -> RnM (LPat RdrName)--- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)--- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]- runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation {- ************************************************************************@@ -205,31 +672,34 @@        -- brackets.        ; let wrapper = QuoteWrapper ev_var m_var        -- Typecheck expr to make sure it is valid.-       -- The typechecked expression won't be used, but we return it with its type.+       -- The typechecked expression won't be used, so we just discard it        --   (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)        -- We'll typecheck it again when we splice it in somewhere        ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $-                               tcScalingUsage Many $-                               -- Scale by Many, TH lifting is currently nonlinear (#18465)-                               tcInferRhoNC expr-                               -- NC for no context; tcBracket does that+                                tcScalingUsage Many $+                                -- Scale by Many, TH lifting is currently nonlinear (#18465)+                                tcInferRhoNC expr+                                -- NC for no context; tcBracket does that        ; let rep = getRuntimeRep expr_ty        ; meta_ty <- tcTExpTy m_var expr_ty        ; ps' <- readMutVar ps_ref        ; codeco <- tcLookupId unsafeCodeCoerceName        ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName+       ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty+                                    , hsb_wrap  = Just wrapper, hsb_splices = ps' }+             -- The tc_expr is stored here so that the expression can be used in HIE files.+             brack_expr = HsTypedBracket brack_tc tc_expr        ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression")                        rn_expr                        (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)                                                   (nlHsTyApp codeco [rep, expr_ty]))-                                      (noLocA (HsTypedBracket (HsBracketTc (ExpBr noExtField expr) bracket_ty (Just wrapper) ps') tc_expr))))+                                      (noLocA brack_expr)))                        meta_ty res_ty }  -- See Note [Typechecking Overloaded Quotes] tcUntypedBracket rn_expr brack ps res_ty   = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) -        -- 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@@ -243,12 +713,15 @@                   Just m_var -> mapM (tcPendingSplice m_var) ps                   Nothing -> assert (null ps) $ return [] +       -- Notice that we don't attempt to typecheck the body+       -- of the bracket, which is in brack.        ; traceTc "tc_bracket done untyped" (ppr expected_type) -       -- Unify the overall type of the bracket with the expected result-       -- type+       -- Unify the overall type of the bracket with the expected result type        ; tcWrapResultO BracketOrigin rn_expr-            (HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote noExtField))+            (HsUntypedBracket (HsBracketTc { hsb_quote = brack, hsb_ty = expected_type+                                           , hsb_wrap = brack_info, hsb_splices = ps' })+                              (XQuote noExtField))                 -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr             expected_type res_ty @@ -339,263 +812,7 @@    -- The whole of the rest of the file is the else-branch (ie stage2 only) -{--Note [How top-level splices are handled]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Top-level splices (those not inside a [| .. |] quotation bracket) are handled-very straightforwardly: -  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)--  2. runMetaT: desugar, compile, run it, and convert result back to-     GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName,-     HsExpr RdrName etc)--  3. treat the result as if that's what you saw in the first place-     e.g for HsType, rename and kind-check-         for HsExpr, rename and type-check--     (The last step is different for decls, because they can *only* be-      top-level: we return the result of step 2.)--Note [How brackets and nested splices are handled]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Nested splices (those inside a [| .. |] quotation bracket),-are treated quite differently.--Remember, there are two forms of bracket-         typed   [|| e ||]-   and untyped   [|  e  |]--The life cycle of a typed bracket:-   * Starts as HsTypedBracket--   * When renaming:-        * Set the ThStage to (Brack s RnPendingTyped)-        * Rename the body-        * Result is a HsTypedBracket--   * When typechecking:-        * Set the ThStage to (Brack s (TcPending ps_var lie_var))-        * Typecheck the body, and keep the elaborated result (despite never using it!)-        * Nested splices (which must be typed) are typechecked, and-          the results accumulated in ps_var; their constraints-          accumulate in lie_var-        * Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack-          where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn--The life cycle of a un-typed bracket:-   * Starts as HsUntypedBracket--   * When renaming:-        * Set the ThStage to (Brack s (RnPendingUntyped ps_var))-        * Rename the body-        * Nested splices (which must be untyped) are renamed, and the-          results accumulated in ps_var-        * Result is a HsUntypedBracket pending_splices rn_body--   * When typechecking:-        * Typecheck the pending_splices individually-        * Ignore the body of the bracket; just check that the context-          expects a bracket of that type (e.g. a [p| pat |] bracket should-          be in a context needing a (Q Pat)-        * Result is a HsUntypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) (XQuote noExtField)-          where rn_brack is the incoming renamed bracket :: HsQuote GhcRn-          and (XQuote noExtField) stands for the removal of the `HsQuote GhcTc` field (since `HsQuote GhcTc` isn't possible)--See the related Note [The life cycle of a TH quotation]--In both cases, desugaring happens like this:-  * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed-    expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It--      a) Extends the ds_meta environment with the PendingSplices-         attached to the bracket--      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when-         run, will produce a suitable TH expression/type/decl.  This-         is why we leave the *renamed* expression attached to the bracket:-         the quoted expression should not be decorated with all the goop-         added by the type checker--  * Each splice carries a unique Name, called a "splice point", thus-    ${n}(e).  The name is initialised to an (Unqual "splice") when the-    splice is created; the renamer gives it a unique.--  * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across-    a splice, it looks up the splice's Name, n, in the ds_meta envt,-    to find an (HsExpr Id) that should be substituted for the splice;-    it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice).--Example:-    Source:       f = [| Just $(g 3) |]-      The [| |] part is a HsUntypedBracket GhcPs--    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}-      The [| |] part is a HsUntypedBracket GhcTc, containing *renamed*-        (not typechecked) expression (see Note [The life cycle of a TH quotation])-      The "s7" is the "splice point"; the (g Int 3) part-        is a typechecked expression--    Desugared:    f = do { s7 <- g Int 3-                         ; return (ConE "Data.Maybe.Just" s7) }---Note [Template Haskell state diagram]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here are the ThStages, s, their corresponding level numbers-(the result of (thLevel s)), and their state transitions.-The top level of the program is stage Comp:--     Start here-         |-         V-      -----------     $      ------------   $-      |  Comp   | ---------> |  Splice  | -----|-      |   1     |            |    0     | <----|-      -----------            -------------        ^     |                ^      |-      $ |     | [||]         $ |      | [||]-        |     v                |      v-   --------------          -----------------   | Brack Comp |          | Brack Splice |-   |     2      |          |      1       |-   --------------          ------------------* Normal top-level declarations start in state Comp-       (which has level 1).-  Annotations start in state Splice, since they are-       treated very like a splice (only without a '$')--* Code compiled in state Splice (and only such code)-  will be *run at compile time*, with the result replacing-  the splice--* The original paper used level -1 instead of 0, etc.--* The original paper did not allow a splice within a-  splice, but there is no reason not to. This is the-  $ transition in the top right.--Note [Template Haskell levels]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Imported things are impLevel (= 0)--* However things at level 0 are not *necessarily* imported.-      eg  $( \b -> ... )   here b is bound at level 0--* In GHCi, variables bound by a previous command are treated-  as impLevel, because we have bytecode for them.--* Variables are bound at the "current level"--* The current level starts off at outerLevel (= 1)--* The level is decremented by splicing $(..)-               incremented by brackets [| |]-               incremented by name-quoting 'f--* When a variable is used, checkWellStaged compares-        bind:  binding level, and-        use:   current level at usage site--  Generally-        bind > use      Always error (bound later than used)-                        [| \x -> $(f x) |]--        bind = use      Always OK (bound same stage as used)-                        [| \x -> $(f [| x |]) |]--        bind < use      Inside brackets, it depends-                        Inside splice, OK-                        Inside neither, OK--  For (bind < use) inside brackets, there are three cases:-    - Imported things   OK      f = [| map |]-    - Top-level things  OK      g = [| f |]-    - Non-top-level     Only if there is a liftable instance-                                h = \(x:Int) -> [| x |]--  To track top-level-ness we use the ThBindEnv in TcLclEnv--  For example:-           f = ...-           g1 = $(map ...)         is OK-           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 GHC.HsToCore.Quote)--`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.--- See Note [Warnings for TH splices].-getThSpliceOrigin :: TcM Origin-getThSpliceOrigin = do-  warn <- goptM Opt_EnableThSpliceWarnings-  if warn then return FromSource else return Generated--{- Note [Warnings for TH splices]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only produce warnings for TH splices when the user requests so-(-fenable-th-splice-warnings). There are multiple reasons:--  * It's not clear that the user that compiles a splice is the author of the code-    that produces the warning. Think of the situation where they just splice in-    code from a third-party library that produces incomplete pattern matches.-    In this scenario, the user isn't even able to fix that warning.-  * Gathering information for producing the warnings (pattern-match check-    warnings in particular) is costly. There's no point in doing so if the user-    is not interested in those warnings.--That's why we store Origin flags in the Haskell AST. The functions from ThToHs-take such a flag and depending on whether TH splice warnings were enabled or-not, we pass FromSource (if the user requests warnings) or Generated-(otherwise). This is implemented in getThSpliceOrigin.--For correct pattern-match warnings it's crucial that we annotate the Origin-consistently (#17270). In the future we could offer the Origin as part of the-TH AST. That would enable us to give quotes from the current module get-FromSource origin, and/or third library authors to tag certain parts of-generated code as FromSource to enable warnings.-That effort is tracked in #14838.--}- {- ************************************************************************ *                                                                      *@@ -604,21 +821,19 @@ ************************************************************************ -} -tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty-  = addErrCtxt (spliceCtxtDoc splice) $+tcTypedSplice splice_name expr res_ty+  = addErrCtxt (typedSpliceCtxtDoc splice_name expr) $     setSrcSpan (getLocA expr)    $ do     { stage <- getStage     ; case stage of           Splice {}            -> tcTopSplice expr res_ty-          Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty+          Brack pop_stage pend -> tcNestedSplice pop_stage pend splice_name expr res_ty           RunSplice _          ->             -- See Note [RunSplice ThLevel] in "GHC.Tc.Types".             pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++-                      "running another splice") (ppr splice)+                      "running another splice") (pprTypedSplice (Just splice_name) expr)           Comp                 -> tcTopSplice expr res_ty     }-tcSpliceExpr splice _-  = pprPanic "tcSpliceExpr" (ppr splice)  {- Note [Collecting modFinalizers in typed splices]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -630,6 +845,59 @@  -} +------------------+tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcTopSplice expr res_ty+  = do { -- Typecheck the expression,+         -- making sure it has type Q (T res_ty)+         res_ty <- expTypeToType 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 $+                   tcCheckMonoExpr expr meta_exp_ty+       ; lcl_env <- getLclEnv+       ; let delayed_splice+              = DelayedSplice lcl_env expr res_ty q_expr+       ; return (HsTypedSplice delayed_splice q_expr)++       }++-------------------+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)+-- Note [How top-level splices are handled]+-- Type check an expression that is the body of a top-level splice+--   (the caller will compile and run it)+-- Note that set the level to Splice, regardless of the original level,+-- before typechecking the expression.  For example:+--      f x = $( ...$(g 3) ... )+-- The recursive call to tcCheckPolyExpr will simply expand the+-- inner escape before dealing with the outer one++tcTopSpliceExpr isTypedSplice tc_action+  = checkNoErrs $  -- checkNoErrs: must not try to run the thing+                   -- if the type checker fails!+    unsetGOptM Opt_DeferTypeErrors $+                   -- Don't defer type errors.  Not only are we+                   -- going to run this code, but we do an unsafe+                   -- coerce, so we get a seg-fault if, say we+                   -- splice a type into a place where an expression+                   -- is expected (#7276)+    setStage (Splice isTypedSplice) $+    do {    -- Typecheck the expression+         (mb_expr', wanted) <- tryCaptureConstraints tc_action+             -- If tc_action fails (perhaps because of insoluble constraints)+             -- we want to capture and report those constraints, else we may+             -- just get a silent failure (#20179). Hence the 'try' part.++       ; const_binds <- simplifyTop wanted++       ; case mb_expr' of+            Nothing    -> failM   -- In this case simplifyTop should have+                                  -- reported some errors+            Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }++------------------ tcNestedSplice :: ThStage -> PendingStuff -> Name                 -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)     -- See Note [How brackets and nested splices are handled]@@ -649,35 +917,13 @@        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)         -- The returned expression is ignored; it's in the pending splices-       -- But we still return a plausible expression-       --   (a) in case we print it in debug messages, and-       --   (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp-       ; return (HsSpliceE noAnn $-                 HsSpliced noExtField (ThModFinalizers []) $-                 HsSplicedExpr (unLoc expr'')) }-+       ; return stubNestedSplice }  tcNestedSplice _ _ splice_name _ _   = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) -tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-tcTopSplice expr res_ty-  = do { -- Typecheck the expression,-         -- making sure it has type Q (T res_ty)-         res_ty <- expTypeToType 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 $-                   tcCheckMonoExpr expr meta_exp_ty-       ; lcl_env <- getLclEnv-       ; let delayed_splice-              = DelayedSplice lcl_env expr res_ty q_expr-       ; return (HsSpliceE noAnn (XSplice (HsSplicedT delayed_splice))) -       }--+------------------ -- This is called in the zonker -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)@@ -715,15 +961,15 @@ {- ************************************************************************ *                                                                      *-\subsection{Error messages}+ *                                                                      * ************************************************************************ -} -spliceCtxtDoc :: HsSplice GhcRn -> SDoc-spliceCtxtDoc splice+typedSpliceCtxtDoc :: SplicePointName -> LHsExpr GhcRn -> SDoc+typedSpliceCtxtDoc n splice   = hang (text "In the Template Haskell splice")-         2 (pprSplice splice)+         2 (pprTypedSplice (Just n) splice)  spliceResultDoc :: LHsExpr GhcTc -> SDoc spliceResultDoc expr@@ -731,40 +977,15 @@         , nest 2 (char '$' <> ppr expr)         , text "To see what the splice expanded to, use -ddump-splices"] ---------------------tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)--- Note [How top-level splices are handled]--- Type check an expression that is the body of a top-level splice---   (the caller will compile and run it)--- Note that set the level to Splice, regardless of the original level,--- before typechecking the expression.  For example:---      f x = $( ...$(g 3) ... )--- The recursive call to tcCheckPolyExpr will simply expand the--- inner escape before dealing with the outer one+stubNestedSplice :: HsExpr GhcTc+-- Used when we need a (LHsExpr GhcTc) that we are never going+-- to look at.  We could use "panic" but that's confusing if we ever+-- do a debug-print.  The warning is because this should never happen+-- /except/ when doing debug prints.+stubNestedSplice = warnPprTrace True "stubNestedSplice" empty $+                   HsLit noComments (mkHsString "stubNestedSplice") -tcTopSpliceExpr isTypedSplice tc_action-  = checkNoErrs $  -- checkNoErrs: must not try to run the thing-                   -- if the type checker fails!-    unsetGOptM Opt_DeferTypeErrors $-                   -- Don't defer type errors.  Not only are we-                   -- going to run this code, but we do an unsafe-                   -- coerce, so we get a seg-fault if, say we-                   -- splice a type into a place where an expression-                   -- is expected (#7276)-    setStage (Splice isTypedSplice) $-    do {    -- Typecheck the expression-         (mb_expr', wanted) <- tryCaptureConstraints tc_action-             -- If tc_action fails (perhaps because of insoluble constraints)-             -- we want to capture and report those constraints, else we may-             -- just get a silent failure (#20179). Hence the 'try' part. -       ; const_binds <- simplifyTop wanted--       ; case mb_expr' of-            Nothing    -> failM   -- In this case simplifyTop should have-                                  -- reported some errors-            Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }- {- ************************************************************************ *                                                                      *@@ -1773,6 +1994,14 @@     rdr_name = case TH.nameModule th_name of                  Nothing  -> mkRdrUnqual occ                  Just mod -> mkRdrQual (mkModuleName mod) occ++-- | We only want to produce warnings for TH-splices if the user requests so.+-- See Note [Warnings for TH splices].+getThSpliceOrigin :: TcM Origin+getThSpliceOrigin = do+  warn <- goptM Opt_EnableThSpliceWarnings+  if warn then return FromSource else return Generated+  getThing :: TH.Name -> TcM TcTyThing getThing th_name
compiler/GHC/Tc/Gen/Splice.hs-boot view
@@ -10,13 +10,13 @@ import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) -import GHC.Hs     ( HsSplice, HsQuote, HsExpr, LHsExpr, LHsType,-                    LPat, LHsDecl, ThModFinalizers )+import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH -tcSpliceExpr :: HsSplice GhcRn-             -> ExpRhoType-             -> TcM (HsExpr GhcTc)+tcTypedSplice :: Name+              -> LHsExpr GhcRn+              -> ExpRhoType+              -> TcM (HsExpr GhcTc)  tcTypedBracket :: HsExpr GhcRn                -> LHsExpr GhcRn
compiler/GHC/Tc/Module.hs view
@@ -3016,7 +3016,7 @@       | otherwise = hasTopUserName id                     && case idDetails id of                          VanillaId    -> True-                         StrictWorkerId{} -> True+                         WorkerLikeId{} -> True                          RecSelId {}  -> True                          ClassOpId {} -> True                          FCallId {}   -> True
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -2141,8 +2141,8 @@     (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)      mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn-    mk_vta fun ty = noLocA (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy-                                                $ noLocA $ XHsType ty))+    mk_vta fun ty = noLocA (HsAppType noExtField fun noHsTok+        (mkEmptyWildCardBndrs $ nlHsParTy $ noLocA $ XHsType ty))        -- NB: use visible type application        -- See Note [Default methods in instances]
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -1088,9 +1088,8 @@                                     = return $ unLoc $ foldl' nlHsApp (noLocA neg)                                                        [noLocA (HsOverLit noAnn n)]         | otherwise                 = return $ HsOverLit noAnn n-    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))-                                    = go1 pat-    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"+    go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat+    go1 (SplicePat (HsUntypedSpliceNested _) _)  = panic "tcPatToExpr: invalid nested splice"     go1 (XPat (HsPatExpanded _ pat))= go1 pat      -- See Note [Invertible view patterns]@@ -1107,9 +1106,6 @@     go1 p@(WildPat {})                       = notInvertible p     go1 p@(AsPat {})                         = notInvertible p     go1 p@(NPlusKPat {})                     = notInvertible p-    go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p-    go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p-    go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p      notInvertible p = Left (not_invertible_msg p) @@ -1275,7 +1271,7 @@      go1 :: Pat GhcTc -> ([TyVar], [EvVar])     go1 (LazyPat _ p)      = go p-    go1 (AsPat _ _ p)      = go p+    go1 (AsPat _ _ _ p)    = go p     go1 (ParPat _ _ p _)   = go p     go1 (BangPat _ p)      = go p     go1 (ListPat _ ps)     = mergeMany . map go $ ps
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -476,10 +476,10 @@     (tyvars, rho) = tcSplitForAllInvisTyVars (idType id)     (theta, tau)  = tcSplitPhiTy rho -tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)+tcInstTypeBndrs :: Type -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)                      -- (type vars, preds (incl equalities), rho) -- Instantiate the binders of a type signature with TyVarTvs-tcInstTypeBndrs id+tcInstTypeBndrs poly_ty   | null tyvars   -- There may be overloading despite no type variables;                   --      (?x :: Int) => Int -> Int   = return ([], theta, tau)@@ -489,7 +489,7 @@              subst'  = extendTCvInScopeSet subst (tyCoVarsOfType rho)        ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }   where-    (tyvars, rho) = splitForAllInvisTVBinders (idType id)+    (tyvars, rho) = splitForAllInvisTVBinders poly_ty     (theta, tau)  = tcSplitPhiTy rho      inst_invis_bndr :: TCvSubst -> InvisTVBinder
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -771,10 +771,10 @@        new_e2 <- zonkLExpr env e2        return (HsApp x new_e1 new_e2) -zonkExpr env (HsAppType ty e t)+zonkExpr env (HsAppType ty e at t)   = do new_e <- zonkLExpr env e        new_ty <- zonkTcTypeToTypeX env ty-       return (HsAppType new_ty new_e t)+       return (HsAppType new_ty new_e at t)        -- NB: the type is an HsType; can't zonk that!  zonkExpr env (HsTypedBracket hsb_tc body)@@ -783,10 +783,9 @@ zonkExpr env (HsUntypedBracket hsb_tc body)   = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc -zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =-  runTopSplice s >>= zonkExpr env+zonkExpr env (HsTypedSplice s _) = runTopSplice s >>= zonkExpr env -zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e)+zonkExpr _ e@(HsUntypedSplice _ _) = pprPanic "zonkExpr: HsUntypedSplice" (ppr e)  zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x @@ -1318,10 +1317,10 @@   = do  { (env', pat') <- zonkPat env pat         ; return (env',  BangPat x pat') } -zonk_pat env (AsPat x (L loc v) pat)+zonk_pat env (AsPat x (L loc v) at pat)   = do  { v' <- zonkIdBndr env v         ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat-        ; return (env', AsPat x (L loc v') pat') }+        ; return (env', AsPat x (L loc v') at pat') }  zonk_pat env (ViewPat ty expr pat)   = do  { expr' <- zonkLExpr env expr
compiler/GHC/ThToHs.hs view
@@ -1002,7 +1002,7 @@     cvt (AppTypeE e t) = do { e' <- cvtl e                             ; t' <- cvtType t                             ; let tp = parenthesizeHsType appPrec t'-                            ; return $ HsAppType noSrcSpan e'+                            ; return $ HsAppType noExtField e' noHsTok                                      $ mkHsWildCardBndrs tp }     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its                                -- own expression to avoid pretty-printing@@ -1387,10 +1387,11 @@                             ; ps' <- cvtPats ps                             ; ts' <- mapM cvtType ts                             ; let pps = map (parenthesizePat appPrec) ps'+                                  pts = map (\t -> HsConPatTyArg noHsTok (mkHsPatSigType noAnn t)) ts'                             ; return $ ConPat                                 { pat_con_ext = noAnn                                 , pat_con = s'-                                , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps+                                , pat_args = PrefixCon pts pps                                 }                             } cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2@@ -1412,7 +1413,7 @@ cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' } cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' } cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p-                            ; return $ AsPat noAnn s' p' }+                            ; return $ AsPat noAnn s' noHsTok p' } cvtp TH.WildP          = return $ WildPat noExtField cvtp (RecP c fs)       = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs                             ; return $ ConPat
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 0.20220601+version: 0.20220701 license: BSD3 license-file: LICENSE category: Development@@ -82,7 +82,7 @@         process >= 1 && < 1.7,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 0.20220601,+        ghc-lib-parser,         stm     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:@@ -182,6 +182,7 @@         GHC.Core.Reduction,         GHC.Core.RoughMap,         GHC.Core.Rules,+        GHC.Core.Rules.Config,         GHC.Core.Seq,         GHC.Core.SimpleOpt,         GHC.Core.Stats,@@ -211,6 +212,7 @@         GHC.Data.FastString.Env,         GHC.Data.FiniteMap,         GHC.Data.Graph.Directed,+        GHC.Data.Graph.UnVar,         GHC.Data.IOEnv,         GHC.Data.List.SetOps,         GHC.Data.Maybe,@@ -228,6 +230,7 @@         GHC.Driver.Backpack.Syntax,         GHC.Driver.CmdLine,         GHC.Driver.Config,+        GHC.Driver.Config.Core.Lint,         GHC.Driver.Config.Diagnostic,         GHC.Driver.Config.Logger,         GHC.Driver.Config.Parser,@@ -380,6 +383,7 @@         GHC.Types.Name.Reader,         GHC.Types.Name.Set,         GHC.Types.PkgQual,+        GHC.Types.ProfAuto,         GHC.Types.RepType,         GHC.Types.SafeHaskell,         GHC.Types.SourceError,@@ -610,7 +614,6 @@         GHC.Data.Graph.Color         GHC.Data.Graph.Ops         GHC.Data.Graph.Ppr-        GHC.Data.Graph.UnVar         GHC.Data.UnionFind         GHC.Driver.Backpack         GHC.Driver.CodeOutput@@ -621,8 +624,11 @@         GHC.Driver.Config.Core.Opt.Arity         GHC.Driver.Config.Core.Opt.LiberateCase         GHC.Driver.Config.Core.Opt.WorkWrap+        GHC.Driver.Config.Core.Rules+        GHC.Driver.Config.CoreToStg.Prep         GHC.Driver.Config.Finder         GHC.Driver.Config.HsToCore+        GHC.Driver.Config.HsToCore.Ticks         GHC.Driver.Config.HsToCore.Usage         GHC.Driver.Config.Stg.Debug         GHC.Driver.Config.Stg.Lift@@ -643,6 +649,7 @@         GHC.HsToCore         GHC.HsToCore.Arrows         GHC.HsToCore.Binds+        GHC.HsToCore.Breakpoints         GHC.HsToCore.Coverage         GHC.HsToCore.Docs         GHC.HsToCore.Expr@@ -663,6 +670,7 @@         GHC.HsToCore.Pmc.Solver         GHC.HsToCore.Pmc.Utils         GHC.HsToCore.Quote+        GHC.HsToCore.Ticks         GHC.HsToCore.Types         GHC.HsToCore.Usage         GHC.HsToCore.Utils
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -268,7 +268,7 @@   , ("readMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then read its contents without modifying the MVar, without possibility\n   of intervention from other threads.")   , ("tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#'.")   , ("isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.")-  , ("IOPort#"," A shared I/O port is almost the same as a 'MVar#'!).\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")+  , ("IOPort#"," A shared I/O port is almost the same as an 'MVar#'.\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")   , ("newIOPort#","Create new 'IOPort#'; initially empty.")   , ("readIOPort#","If 'IOPort#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an 'IOPortException' if another thread is already\n   waiting to read this 'IOPort#'.")   , ("writeIOPort#","If 'IOPort#' is full, immediately return with integer 0,\n    throwing an 'IOPortException'.\n    Otherwise, store value arg as 'IOPort#''s new contents,\n    and return with integer 1. ")@@ -295,6 +295,7 @@   , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ")   , ("numSparks#"," Returns the number of sparks in the local spark pool. ")   , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n     of the computation @k@. ")+  , ("dataToTag#"," Evaluates the argument and returns the tag of the result.\n     Tags are Zero-indexed; the first constructor has tag zero. ")   , ("BCO"," Primitive bytecode type. ")   , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ")   , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an 'unsafeCoerce#', but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that 'Addr#' is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -629,7 +629,7 @@ primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy) primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVarSpec] [alphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVarSpec] [intPrimTy] (alphaTy)-primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy])) primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy])) primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVarSpec] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy])) primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVarSpec, deltaTyVarSpec] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))
ghc-lib/stage0/lib/llvm-targets view
@@ -54,6 +54,5 @@ ,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align")) ,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("x86_64-unknown-openbsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+retpoline-indirect-calls +retpoline-indirect-branches"))-,("i386-unknown-openbsd", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "i586", "")) ,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]
ghc-lib/stage0/lib/settings view
@@ -7,13 +7,13 @@ ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")-,("ld command", "/usr/bin/ld")+,("ld command", "ld") ,("ld flags", "") ,("ld supports compact unwind", "YES") ,("ld supports build-id", "NO") ,("ld supports filelist", "YES") ,("ld is GNU ld", "NO")-,("Merge objects command", "/usr/bin/ld")+,("Merge objects command", "ld") ,("Merge objects flags", "-r") ,("ar command", "/usr/bin/ar") ,("ar flags", "qcls")