+{-# 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

+

+  code <- case rhs of

+    -- 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]

+    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

+     -- when `BRK_FUN` in a case continuation BCO executes,

+     -- the stack will already have a full continuation that just

+     -- re-executes the BCO being stopped at (including the stg_ret and

+     -- stg_ctoi frames)

+     --

+     -- right after the `BRK_FUN`, all case continuations will drop the

+     -- stg_ret and stg_ctoi headers (see alt_final1, alt_final2), leaving

+     -- the stack with the bound return values followed by the free variables

+     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_final2

+            Just ibi -> BRK_FUN ibi `consOL` alt_final2

+       _ -> pure alt_final2

+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

+

+     -- Block until this thread is resumed (by the thread which took the

+     -- `ResumeContext` from the `statusMVar`).

+     --

+     -- The `onBreak` function must have been called from `rts/Interpreter.c`

+     -- when interpreting a `BRK_FUN`. After taking from the MVar, the function

+     -- returns to the continuation on the stack which is where the interpreter

+     -- was stopped.

+STATIC_INLINE int

+is_ctoi_nontuple_frame(const StgPtr frame_head) {

+  return (

+      (W_)frame_head == (W_)&stg_ctoi_R1p_info ||

+      (W_)frame_head == (W_)&stg_ctoi_R1n_info ||

+      (W_)frame_head == (W_)&stg_ctoi_F1_info ||

+      (W_)frame_head == (W_)&stg_ctoi_D1_info ||

+      (W_)frame_head == (W_)&stg_ctoi_L1_info ||

+      (W_)frame_head == (W_)&stg_ctoi_V_info

+    );

+}

+                  cap->r.rCCCS = (CostCentreStack*)ReadSpW(offset + 4);

+        /* check for a breakpoint on the beginning of a BCO */

+               W_ stack_head = ReadSpW(0);

+

+               // See Note [Stack layout when entering run_BCO blah]

+               // When the BRK_FUN is at the start of a case continuation BCO,

+               // the stack contains the frame returning the value at the start.

+               int is_case_cont_BCO =

+                       stack_head == (W_)&stg_ret_t_info

+                    || stack_head == (W_)&stg_ret_v_info

+                    || stack_head == (W_)&stg_ret_p_info

+                    || stack_head == (W_)&stg_ret_n_info

+                    || stack_head == (W_)&stg_ret_f_info

+                    || stack_head == (W_)&stg_ret_d_info

+                    || stack_head == (W_)&stg_ret_l_info;

+

+               else if (

+                  /* Doing :step (but don't stop at case continuation BCOs) */

+                  (stop_next_breakpoint == true && !is_case_cont_BCO)

+                  /* Or breakpoint is explicitly enabled */

+                  || ignore_count == 0)

+                  // TODO: WRITE NOTE

+                  if (is_case_cont_BCO) {

+

+                    // TODO: WRITE NOTE

+                    // A case cont. BCO is headed by a ret_frame with the returned value

+                    // We need the frame here if we are going to yield to construct a well formed stack

+                    // Then, just afterwards, we SLIDE the header off. This is generated code (see StgToByteCode)

+                    int size_returned_frame =

+                        (stack_head == (W_)&stg_ret_t_info)

+                        ? 2 /* ret_t + tuple_BCO */

+                          + /* Sp(2) is call_info which records the offset to the next frame

+                             * See also Note [unboxed tuple bytecodes and tuple_BCO] */

+                          ((ReadSpW(2) & 0xFF))

+                        : 2; /* ret_* + return value */

+

+                    StgPtr cont_frame_head

+                        = (StgPtr)(SpW(size_returned_frame));

+                    ASSERT(obj == UNTAG_CLOSURE((StgClosure*)ReadSpW(size_returned_frame+1)));

+

+                    // stg_ctoi_*

+                    int size_cont_frame_head =

+                        is_ctoi_nontuple_frame(cont_frame_head)

+                        ? 2 // info+bco

+#if defined(PROFILING)

+                        : 5;  // or info+bco+tuple_info+tuple_BCO+CCS

+#else

+                        : 4;  // or info+bco+tuple_info+tuple_BCO

+#endif

+

+                    // Continuation stack is already well formed,

+                    // so just copy it whole to the AP_STACK

+                    size_words = size_returned_frame

+                               + size_cont_frame_head

+                               + BCO_BITMAP_SIZE(obj) /* payload of cont_frame */;

+                    new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));

+                    new_aps->size = size_words;

+                    new_aps->fun = &stg_dummy_ret_closure;

+

+                    // (1) Fill in the payload of the AP_STACK:

+                    for (i = 0; i < size_words; i++) {

+                       new_aps->payload[i] = (StgClosure *)ReadSpW(i);

+                    }

+                  }

+                  else {

+                    // (1) Allocate memory for a new AP_STACK, enough to store

+                    // the top stack frame plus an stg_apply_interp_info pointer

+                    // and a pointer to the BCO

+                    size_words = BCO_BITMAP_SIZE(obj) + 2;

+                    new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));

+                    new_aps->size = size_words;

+                    new_aps->fun = &stg_dummy_ret_closure;

+

+                    // (1.1) the continuation frame

+                    new_aps->payload[0] = (StgClosure *)&stg_apply_interp_info;

+                    new_aps->payload[1] = (StgClosure *)obj;

+

+                    // (1.2.1) copy the args/free vars of the top stack frame into the AP_STACK

+                    for (i = 2; i < size_words; i++) {

+                       new_aps->payload[i] = (StgClosure *)ReadSpW(i-2);

+                    }

+                  // (2) Arrange the stack to call the breakpoint IO action, and

+                  // (2.1) Construct the continuation to which we'll return in

+                  // this thread after the `rts_breakpoint_io_action` returns.

+                  //

+                  // For case continuation BCOs, the continuation that re-runs

+                  // it is always ready at the start of the BCO. It gets

+                  // dropped soon after if we don't stop there by SLIDEing.

+                  // See Note [TODO]

+                  if (!is_case_cont_BCO) {

+                    Sp_subW(2); // stg_apply_interp_info + StgBCO*

+

+                    // (2.1.2) Write the continuation frame (above the stg_ret

+                    // frame if one exists)

+                    SpW(1) = (W_)obj;

+                    SpW(0) = (W_)&stg_apply_interp_info;

+                  }

+

+                  // (2.2) The `rts_breakpoint_io_action` call

+                  Sp_subW(11);

+                  SpW(9)  = (W_)False_closure;         // True <=> an exception

+                  SpW(8)  = (W_)&stg_ap_ppv_info;

+Stopped in T9., T26042g.hs:(6,3)-(8,21)

+5  top = do

+   vv

+6    case succ 14 of

+                        ^^

+test('T26042c', [extra_hc_opts('-O -fno-unoptimized-core-for-interpreter'), extra_files(['T26042c.hs'])], ghci_script, ['T26042c.script'])