+{-# LANGUAGE DerivingStrategies #-}

+  , InternalBreakLoc(..)

+  , getBreakSourceId, getBreakSourceMod

+   , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)

+     --

+     -- If there is no original tick identifier (that is, the breakpoint was

+     -- created during code generation), instead refer directly to the SrcSpan

+     -- we want to use for it. See Note [Internal Breakpoint Locations]

+-- | Breakpoints created during code generation don't have a source-level tick

+-- location. Instead, we come up with one ourselves.

+-- See Note [Internal Breakpoint Locations]

+newtype InternalBreakLoc = InternalBreakLoc SrcSpan

+  deriving newtype (Eq, Show, NFData, Outputable)

+

+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> Either InternalBreakLoc BreakpointId

+-- | Get the source module for this breakpoint (where the breakpoint is defined)

+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module

+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =

+  assert_modules_match ibi_mod (imodBreaks_module imbs) $

+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix

+     in case cgb_tick_id cgb of

+      Left InternalBreakLoc{} -> imodBreaks_module imbs

+      Right BreakpointId{bi_tick_mod} -> bi_tick_mod

+

+getBreakLoc = getBreakXXX modBreaks_locs (\(InternalBreakLoc x) -> x)

+getBreakVars = getBreakXXX modBreaks_vars (const [])

+getBreakDecls = getBreakXXX modBreaks_decls (const [])

+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (Maybe (String, String))

+getBreakCCS = getBreakXXX (fmap Just . modBreaks_ccs) (const Nothing)

+-- When there is no tick module (the breakpoint was generated at codegen), use

+-- the function on internal mod breaks.

+--

+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (InternalBreakLoc -> a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a

+getBreakXXX view viewInternal lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =

+      Right BreakpointId{bi_tick_mod, bi_tick_index}

+      Left l ->

+          return $ viewInternal l

+import GHC.ByteCode.Breakpoints

+                      case cgb_tick_id info of

+                        Right bi -> fromMaybe (toRemotePtr nullPtr)

+                          (M.lookup bi ccss)

+                        Left InternalBreakLoc{} -> toRemotePtr nullPtr

+          case cgb_tick_id cgi of

+            Right (BreakpointId tick_mod tick_ix)

+              -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi])

+            Left _

+              -> bmp

+          return $ Just $ getBreakSourceMod ibi brks

+  return $ getBreakSourceMod ibi brks

+import GHC.Runtime.Interpreter ( interpreterProfiled, readIModModBreaks )

+import Data.Array ((!))

+schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do

+  platform <- profilePlatform <$> getProfile

+

+  -- When we find a tick surrounding a case expression we introduce a new BRK_FUN

+  -- instruction at the start of the case *continuation*, in addition to the

+  -- usual BRK_FUN surrounding the StgCase)

+  -- See Note [TODO]

+  code <- case rhs of

+    StgCase scrut bndr _ alts

+      -> doCase d 0 p (Just bp) scrut bndr alts

+    _ -> schemeE d 0 p rhs

+

+  let idOffSets = getVarOffSets platform d p fvs

+      ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)

+      toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)

+      toWord = fmap (\(i, wo) -> (i, fromIntegral wo))

+      breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Right tick_id)

+

+  mibi <- newBreakInfo breakInfo

+

+  return $ case mibi of

+    Nothing  -> code

+    Just ibi -> BRK_FUN ibi `consOL` code

+   = doCase d s p Nothing scrut bndr alts

+    -> Maybe StgTickish

+    -- ^ The breakpoint surrounding the full case expression, if any (only

+    -- source-level cases get breakpoint ticks, and those are the only we care

+    -- about). See Note [TODO]

+doCase d s p m_bid scrut bndr alts

+

+     alt_final <- case m_bid of

+       Just (Breakpoint tick_ty tick_id fvs)

+         | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env)

+         -- Construct an internal breakpoint to put at the start of this case

+         -- continuation BCO.

+         -- See Note [TODO]

+         -> do

+          internal_tick_loc <- makeCaseInternalBreakLoc tick_id

+

+          -- same fvs available in the case expression are available in the case continuation

+          let idOffSets = getVarOffSets platform d p fvs

+              ty_vars   = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs)

+              toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word)

+              toWord = fmap (\(i, wo) -> (i, fromIntegral wo))

+              breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty (Left internal_tick_loc)

+

+          mibi <- newBreakInfo breakInfo

+          return $ case mibi of

+            Nothing  -> alt_final1

+            Just ibi -> BRK_FUN ibi `consOL` alt_final1

+       _ -> pure alt_final1

+makeCaseInternalBreakLoc :: BreakpointId -> BcM InternalBreakLoc

+makeCaseInternalBreakLoc bid = do

+  hug         <- hsc_HUG <$> getHscEnv

+  curr_mod    <- getCurrentModule

+  mb_mod_brks <- getCurrentModBreaks

+

+  -- TODO: Subtract the scrutinee loc from the case loc to get continuation loc

+  InternalBreakLoc <$> case bid of

+    BreakpointId{bi_tick_mod, bi_tick_index}

+      | bi_tick_mod == curr_mod

+      , Just these_mbs <- mb_mod_brks

+      -> do

+        return $ modBreaks_locs these_mbs ! bi_tick_index

+      | otherwise

+      -> do

+        other_mbs <- liftIO $ readIModModBreaks hug bi_tick_mod

+        return $ modBreaks_locs other_mbs ! bi_tick_index

+

+newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId)

+newBreakInfo info = BcM $ \env st -> do

+  -- if we're not generating ModBreaks for this module for some reason, we

+  -- can't store breakpoint occurrence information.

+  case modBreaks env of

+    Nothing -> pure (Nothing, st)

+    Just modBreaks -> do

+      let ix = breakInfoIdx st

+          st' = st

+            { breakInfo = IntMap.insert ix info (breakInfo st)

+            , breakInfoIdx = ix + 1

+            }

+      return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st')

+dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo

+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod)

+                                  Right (breakId loc) == bi ]

+        getBreakSourceMod ibi brks