Generate stack traces for calls to bug and similar.

2024-11-13 09:55:35 +03:00 · 2022-10-20 16:21:15 -04:00 · 2022-10-20 16:21:15 -04:00 · 74c3c7dda3
commit 74c3c7dda3
parent 8310925bc2
10 changed files with 156 additions and 88 deletions
--- a/parser-typechecker/src/Unison/Runtime/Exception.hs
+++ b/parser-typechecker/src/Unison/Runtime/Exception.hs
@ -6,10 +6,11 @@ import Data.Text
 import GHC.Stack
 import Unison.Runtime.Stack
 import Unison.Util.Pretty as P
+import Unison.Reference (Reference)

 data RuntimeExn
  = PE CallStack (P.Pretty P.ColorText)
-  | BU Text Closure
+  | BU [(Reference,Int)] Text Closure
  deriving (Show)

 instance Exception RuntimeExn
--- a/parser-typechecker/src/Unison/Runtime/Interface.hs
+++ b/parser-typechecker/src/Unison/Runtime/Interface.hs
@ -92,6 +92,7 @@ import Unison.Runtime.Pattern
 import Unison.Runtime.Serialize as SER
 import Unison.Runtime.Stack
 import Unison.Symbol (Symbol)
+import Unison.Syntax.NamePrinter (prettyHashQualified)
 import Unison.Syntax.TermPrinter
 import qualified Unison.Term as Tm
 import Unison.Util.EnumContainers as EC
@ -361,7 +362,7 @@ evalInContext ppe ctx activeThreads w = do
      decom = decompile (backReferenceTm crs (decompTm ctx))

      prettyError (PE _ p) = p
-      prettyError (BU nm c) = either id (bugMsg ppe nm) $ decom c
+      prettyError (BU tr nm c) = either id (bugMsg ppe tr nm) $ decom c

      tr tx c = case decom c of
        Right dv -> do
@ -394,13 +395,18 @@ executeMainComb init cc = do
    Right () -> pure (Right ())
  where
    formatErr (PE _ msg) = pure msg
-    formatErr (BU nm c) = do
+    formatErr (BU tr nm c) = do
      crs <- readTVarIO (combRefs cc)
      let decom = decompile (backReferenceTm crs (decompTm $ cacheContext cc))
-      pure . either id (bugMsg PPE.empty nm) $ decom c
+      pure . either id (bugMsg PPE.empty tr nm) $ decom c

-bugMsg :: PrettyPrintEnv -> Text -> Term Symbol -> Pretty ColorText
-bugMsg ppe name tm
+bugMsg
+  :: PrettyPrintEnv
+  -> [(Reference, Int)]
+  -> Text
+  -> Term Symbol
+  -> Pretty ColorText
+bugMsg ppe tr name tm
  | name == "blank expression" =
      P.callout icon . P.lines $
        [ P.wrap
@ -409,8 +415,8 @@ bugMsg ppe name tm
            ),
          "",
          P.indentN 2 $ pretty ppe tm,
-          "",
-          sorryMsg
+          "\n",
+          stackTrace ppe tr
        ]
  | "pattern match failure" `isPrefixOf` name =
      P.callout icon . P.lines $
@ -423,13 +429,16 @@ bugMsg ppe name tm
          "",
          "This happens when calling a function that doesn't handle all \
          \possible inputs",
-          sorryMsg
+          "\n",
+          stackTrace ppe tr
        ]
  | name == "builtin.raise" =
      P.callout icon . P.lines $
        [ P.wrap ("The program halted with an unhandled exception:"),
          "",
-          P.indentN 2 $ pretty ppe tm
+          P.indentN 2 $ pretty ppe tm,
+          "\n",
+          stackTrace ppe tr
        ]
  | name == "builtin.bug",
    RF.TupleTerm' [Tm.Text' msg, x] <- tm,
@ -444,9 +453,10 @@ bugMsg ppe name tm
          "",
          "This happens when calling a function that doesn't handle all \
          \possible inputs",
-          sorryMsg
+          "\n",
+          stackTrace ppe tr
        ]
-bugMsg ppe name tm =
+bugMsg ppe tr name tm =
  P.callout icon . P.lines $
    [ P.wrap
        ( "I've encountered a call to" <> P.red (P.text name)
@ -454,18 +464,26 @@ bugMsg ppe name tm =
        ),
      "",
      P.indentN 2 $ pretty ppe tm,
-      "",
-      sorryMsg
+      "\n",
+      stackTrace ppe tr
    ]
-  where

-icon, sorryMsg :: Pretty ColorText
+stackTrace :: PrettyPrintEnv -> [(Reference, Int)] -> Pretty ColorText
+stackTrace ppe tr = "Stack trace:\n" <> P.indentN 2 (P.lines $ f <$> tr)
+  where
+    f (rf, n) = name <> count
+      where
+        count
+          | n > 1 = " (" <> fromString (show n) <> " copies)"
+          | otherwise = ""
+        name =
+          syntaxToColor .
+            prettyHashQualified .
+            PPE.termName ppe .
+            RF.Ref $ rf
+
+icon :: Pretty ColorText
 icon = "💔💥"
-sorryMsg =
-  P.wrap $
-    "I'm sorry this message doesn't have more detail about"
-      <> "the location of the failure."
-      <> "My makers plan to fix this in a future release. 😢"

 catchInternalErrors ::
  IO (Either Error a) ->
@ -536,7 +554,7 @@ tryM :: IO () -> IO (Maybe Error)
 tryM = fmap (either (Just . extract) (const Nothing)) . try
  where
    extract (PE _ e) = e
-    extract (BU _ _) = "impossible"
+    extract (BU _ _ _) = "impossible"

 runStandalone :: StoredCache -> Word64 -> IO (Either (Pretty ColorText) ())
 runStandalone sc init =
--- a/parser-typechecker/src/Unison/Runtime/MCode.hs
+++ b/parser-typechecker/src/Unison/Runtime/MCode.hs
@ -28,6 +28,7 @@ module Unison.Runtime.MCode
    emitComb,
    emptyRNs,
    argsToLists,
+    combRef,
    combDeps,
    combTypes,
    prettyCombs,
@ -543,6 +544,9 @@ data CombIx
      !Word64 -- section
  deriving (Eq, Ord, Show)

+combRef :: CombIx -> Reference
+combRef (CIx r _ _) = r
+
 data RefNums = RN
  { dnum :: Reference -> Word64,
    cnum :: Reference -> Word64
--- a/parser-typechecker/src/Unison/Runtime/Machine.hs
+++ b/parser-typechecker/src/Unison/Runtime/Machine.hs
@ -152,7 +152,7 @@ eval0 !env !activeThreads !co = do
  bstk <- alloc
  (denv, k) <-
    topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env)
-  eval env denv activeThreads ustk bstk (k KE) co
+  eval env denv activeThreads ustk bstk (k KE) dummyRef co

 topDEnv ::
  M.Map Reference Word64 ->
@ -241,31 +241,32 @@ exec ::
  Stack 'UN ->
  Stack 'BX ->
  K ->
+  Reference ->
  Instr ->
  IO (DEnv, Stack 'UN, Stack 'BX, K)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Info tx) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Info tx) = do
  info tx ustk
  info tx bstk
  info tx k
  pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (Name r args) = do
+exec !env !denv !_activeThreads !ustk !bstk !k _ (Name r args) = do
  bstk <- name ustk bstk args =<< resolve env denv bstk r
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (SetDyn p i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (SetDyn p i) = do
  clo <- peekOff bstk i
  pure (EC.mapInsert p clo denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Capture p) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Capture p) = do
  (cap, denv, ustk, bstk, k) <- splitCont denv ustk bstk k p
  bstk <- bump bstk
  poke bstk cap
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (UPrim1 op i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (UPrim1 op i) = do
  ustk <- uprim1 ustk op i
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (UPrim2 op i j) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (UPrim2 op i j) = do
  ustk <- uprim2 ustk op i j
  pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 MISS i)
  | sandboxed env = die "attempted to use sandboxed operation: isMissing"
  | otherwise = do
      clink <- peekOff bstk i
@ -274,7 +275,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i)
      ustk <- bump ustk
      if (link `M.member` m) then poke ustk 1 else poke ustk 0
      pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CACH i)
  | sandboxed env = die "attempted to use sandboxed operation: cache"
  | otherwise = do
      arg <- peekOffS bstk i
@ -285,7 +286,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i)
        bstk
        (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown)
      pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CVLD i)
  | sandboxed env = die "attempted to use sandboxed operation: validate"
  | otherwise = do
      arg <- peekOffS bstk i
@ -303,7 +304,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i)
          pokeOffBi bstk 1 msg
          pokeOff bstk 2 clo
          pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LKUP i)
  | sandboxed env = die "attempted to use sandboxed operation: lookup"
  | otherwise = do
      clink <- peekOff bstk i
@ -323,14 +324,14 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i)
          bstk <- bump bstk
          bstk <$ pokeBi bstk sg
      pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 TLTT i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim1 TLTT i) = do
  clink <- peekOff bstk i
  let Ref link = unwrapForeign $ marshalToForeign clink
  let sh = Util.Text.fromText . SH.toText $ toShortHash link
  bstk <- bump bstk
  pokeBi bstk sh
  pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LOAD i)
  | sandboxed env = die "attempted to use sandboxed operation: load"
  | otherwise = do
      v <- peekOffBi bstk i
@ -345,16 +346,16 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i)
          poke ustk 1
          poke bstk x
      pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) = do
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 VALU i) = do
  m <- readTVarIO (tagRefs env)
  c <- peekOff bstk i
  bstk <- bump bstk
  pokeBi bstk =<< reflectValue m c
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 op i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim1 op i) = do
  (ustk, bstk) <- bprim1 ustk bstk op i
  pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 SDBX i j) = do
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 SDBX i j) = do
  s <- peekOffS bstk i
  c <- peekOff bstk j
  l <- decodeSandboxArgument s
@ -362,92 +363,96 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 SDBX i j) = do
  ustk <- bump ustk
  poke ustk $ if b then 1 else 0
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim2 EQLU i j) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim2 EQLU i j) = do
  x <- peekOff bstk i
  y <- peekOff bstk j
  ustk <- bump ustk
  poke ustk $ if universalEq (==) x y then 1 else 0
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim2 CMPU i j) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim2 CMPU i j) = do
  x <- peekOff bstk i
  y <- peekOff bstk j
  ustk <- bump ustk
  poke ustk . fromEnum $ universalCompare compare x y
  pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 TRCE i j)
+exec !_   !_    !_activeThreads !_    !bstk !k r (BPrim2 THRO i j) = do
+  name <- peekOffBi @Util.Text.Text bstk i
+  x <- peekOff bstk j
+  throwIO (BU (traceK r k) (Util.Text.toText name) x)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 TRCE i j)
  | sandboxed env = die "attempted to use sandboxed operation: trace"
  | otherwise = do
      tx <- peekOffBi bstk i
      clo <- peekOff bstk j
      tracer env tx clo
      pure (denv, ustk, bstk, k)
-exec !_ !denv !_trackThreads !ustk !bstk !k (BPrim2 op i j) = do
+exec !_ !denv !_trackThreads !ustk !bstk !k _ (BPrim2 op i j) = do
  (ustk, bstk) <- bprim2 ustk bstk op i j
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Pack r t args) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Pack r t args) = do
  clo <- buildData ustk bstk r t args
  bstk <- bump bstk
  poke bstk clo
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Unpack r i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Unpack r i) = do
  (ustk, bstk) <- dumpData r ustk bstk =<< peekOff bstk i
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Print i) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Print i) = do
  t <- peekOffBi bstk i
  Tx.putStrLn (Util.Text.toText t)
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MI n)) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MI n)) = do
  ustk <- bump ustk
  poke ustk n
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MD d)) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MD d)) = do
  ustk <- bump ustk
  pokeD ustk d
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MT t)) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MT t)) = do
  bstk <- bump bstk
  poke bstk (Foreign (Wrap Rf.textRef t))
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MM r)) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MM r)) = do
  bstk <- bump bstk
  poke bstk (Foreign (Wrap Rf.termLinkRef r))
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MY r)) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MY r)) = do
  bstk <- bump bstk
  poke bstk (Foreign (Wrap Rf.typeLinkRef r))
  pure (denv, ustk, bstk, k)
-exec !_ !denv !_activeThreads !ustk !bstk !k (Reset ps) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Reset ps) = do
  (ustk, ua) <- saveArgs ustk
  (bstk, ba) <- saveArgs bstk
  pure (denv, ustk, bstk, Mark ua ba ps clos k)
  where
    clos = EC.restrictKeys denv ps
-exec !_ !denv !_activeThreads !ustk !bstk !k (Seq as) = do
+exec !_ !denv !_activeThreads !ustk !bstk !k _ (Seq as) = do
  l <- closureArgs bstk as
  bstk <- bump bstk
  pokeS bstk $ Sq.fromList l
  pure (denv, ustk, bstk, k)
-exec !env !denv !_activeThreads !ustk !bstk !k (ForeignCall _ w args)
+exec !env !denv !_activeThreads !ustk !bstk !k _ (ForeignCall _ w args)
  | Just (FF arg res ev) <- EC.lookup w (foreignFuncs env) =
      uncurry (denv,,,k)
        <$> (arg ustk bstk args >>= ev >>= res ustk bstk)
  | otherwise =
      die $ "reference to unknown foreign function: " ++ show w
-exec !env !denv !activeThreads !ustk !bstk !k (Fork i)
+exec !env !denv !activeThreads !ustk !bstk !k _ (Fork i)
  | sandboxed env = die "attempted to use sandboxed operation: fork"
  | otherwise = do
      tid <- forkEval env activeThreads =<< peekOff bstk i
      bstk <- bump bstk
      poke bstk . Foreign . Wrap Rf.threadIdRef $ tid
      pure (denv, ustk, bstk, k)
-exec !env !denv !activeThreads !ustk !bstk !k (Atomically i)
+exec !env !denv !activeThreads !ustk !bstk !k _ (Atomically i)
  | sandboxed env = die $ "attempted to use sandboxed operation: atomically"
  | otherwise = do
      c <- peekOff bstk i
      bstk <- bump bstk
      atomicEval env activeThreads (poke bstk) c
      pure (denv, ustk, bstk, k)
-exec !env !denv !activeThreads !ustk !bstk !k (TryForce i)
+exec !env !denv !activeThreads !ustk !bstk !k _ (TryForce i)
  | sandboxed env = die $ "attempted to use sandboxed operation: tryForce"
  | otherwise = do
      c <- peekOff bstk i
@ -478,7 +483,7 @@ encodeExn ustk bstk (Left exn) = do
      | Just re <- fromException exn = case re of
          PE _stk msg ->
            (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue)
-          BU tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl)
+          BU _ tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl)
      | Just (ae :: ArithException) <- fromException exn =
          (Rf.arithmeticFailureRef, disp ae, unitValue)
      | Just (nae :: NestedAtomically) <- fromException exn =
@ -496,15 +501,16 @@ eval ::
  Stack 'UN ->
  Stack 'BX ->
  K ->
+  Reference ->
  Section ->
  IO ()
-eval !env !denv !activeThreads !ustk !bstk !k (Match i (TestT df cs)) = do
+eval !env !denv !activeThreads !ustk !bstk !k r (Match i (TestT df cs)) = do
  t <- peekOffBi bstk i
-  eval env denv activeThreads ustk bstk k $ selectTextBranch t df cs
-eval !env !denv !activeThreads !ustk !bstk !k (Match i br) = do
+  eval env denv activeThreads ustk bstk k r $ selectTextBranch t df cs
+eval !env !denv !activeThreads !ustk !bstk !k r (Match i br) = do
  n <- peekOffN ustk i
-  eval env denv activeThreads ustk bstk k $ selectBranch n br
-eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
+  eval env denv activeThreads ustk bstk k r $ selectBranch n br
+eval !env !denv !activeThreads !ustk !bstk !k _ (Yield args)
  | asize ustk + asize bstk > 0,
    BArg1 i <- args =
      peekOff bstk i >>= apply env denv activeThreads ustk bstk k False ZArgs
@ -513,23 +519,23 @@ eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
      ustk <- frameArgs ustk
      bstk <- frameArgs bstk
      yield env denv activeThreads ustk bstk k
-eval !env !denv !activeThreads !ustk !bstk !k (App ck r args) =
+eval !env !denv !activeThreads !ustk !bstk !k _ (App ck r args) =
  resolve env denv bstk r
    >>= apply env denv activeThreads ustk bstk k ck args
-eval !env !denv !activeThreads !ustk !bstk !k (Call ck n args) =
+eval !env !denv !activeThreads !ustk !bstk !k _ (Call ck n args) =
  combSection env (CIx dummyRef n 0)
    >>= enter env denv activeThreads ustk bstk k ck args
-eval !env !denv !activeThreads !ustk !bstk !k (Jump i args) =
+eval !env !denv !activeThreads !ustk !bstk !k _ (Jump i args) =
  peekOff bstk i >>= jump env denv activeThreads ustk bstk k args
-eval !env !denv !activeThreads !ustk !bstk !k (Let nw cix) = do
+eval !env !denv !activeThreads !ustk !bstk !k r (Let nw cix) = do
  (ustk, ufsz, uasz) <- saveFrame ustk
  (bstk, bfsz, basz) <- saveFrame bstk
-  eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) nw
-eval !env !denv !activeThreads !ustk !bstk !k (Ins i nx) = do
-  (denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k i
-  eval env denv activeThreads ustk bstk k nx
-eval !_ !_ !_ !_activeThreads !_ !_ Exit = pure ()
-eval !_ !_ !_ !_activeThreads !_ !_ (Die s) = die s
+  eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) r nw
+eval !env !denv !activeThreads !ustk !bstk !k r (Ins i nx) = do
+  (denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k r i
+  eval env denv activeThreads ustk bstk k r nx
+eval !_ !_ !_ !_activeThreads !_ !_ _ Exit = pure ()
+eval !_ !_ !_ !_activeThreads !_ !_ _ (Die s) = die s
 {-# NOINLINE eval #-}

 forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId
@ -587,7 +593,9 @@ enter !env !denv !activeThreads !ustk !bstk !k !ck !args !comb = do
  (ustk, bstk) <- moveArgs ustk bstk args
  ustk <- acceptArgs ustk ua
  bstk <- acceptArgs bstk ba
-  eval env denv activeThreads ustk bstk k entry
+  -- TODO: start putting references in `Call` if we ever start
+  -- detecting saturated calls.
+  eval env denv activeThreads ustk bstk k dummyRef entry
  where
    Lam ua ba uf bf entry = comb
 {-# INLINE enter #-}
@ -626,7 +634,7 @@ apply !env !denv !activeThreads !ustk !bstk !k !ck !args (PAp comb useg bseg) =
          bstk <- dumpSeg bstk bseg A
          ustk <- acceptArgs ustk ua
          bstk <- acceptArgs bstk ba
-          eval env denv activeThreads ustk bstk k entry
+          eval env denv activeThreads ustk bstk k (combRef comb) entry
      | otherwise -> do
          (useg, bseg) <- closeArgs C ustk bstk useg bseg args
          ustk <- discardFrame =<< frameArgs ustk
@ -1594,10 +1602,7 @@ bprim2 !ustk !bstk CATB i j = do
  bstk <- bump bstk
  pokeBi bstk (l <> r :: By.Bytes)
  pure (ustk, bstk)
-bprim2 !_ !bstk THRO i j = do
-  name <- peekOffBi @Util.Text.Text bstk i
-  x <- peekOff bstk j
-  throwIO (BU (Util.Text.toText name) x)
+bprim2 !ustk !bstk THRO _ _ = pure (ustk, bstk) -- impossible
 bprim2 !ustk !bstk TRCE _ _ = pure (ustk, bstk) -- impossible
 bprim2 !ustk !bstk CMPU _ _ = pure (ustk, bstk) -- impossible
 bprim2 !ustk !bstk SDBX _ _ = pure (ustk, bstk) -- impossible
@ -1626,7 +1631,7 @@ yield !env !denv !activeThreads !ustk !bstk !k = leap denv k
      bstk <- restoreFrame bstk bfsz basz
      ustk <- ensure ustk uf
      bstk <- ensure bstk bf
-      eval env denv activeThreads ustk bstk k nx
+      eval env denv activeThreads ustk bstk k (combRef cix) nx
    leap _ (CB (Hook f)) = f ustk bstk
    leap _ KE = pure ()
 {-# INLINE yield #-}
--- a/parser-typechecker/src/Unison/Runtime/Stack.hs
+++ b/parser-typechecker/src/Unison/Runtime/Stack.hs
@ -17,6 +17,7 @@ module Unison.Runtime.Stack
    Off,
    SZ,
    FP,
+    traceK,
    frameDataSize,
    marshalToForeign,
    unull,
@ -109,6 +110,14 @@ data Closure
  | BlackHole
  deriving (Show, Eq, Ord)

+traceK :: Reference -> K -> [(Reference, Int)]
+traceK begin = dedup (begin, 1) where
+  dedup p (Mark _ _ _ _ k) = dedup p k
+  dedup p@(cur,n) (Push _ _ _ _ (CIx r _ _) k)
+    | cur == r = dedup (cur,1+n) k
+    | otherwise = p : dedup (r,1) k
+  dedup p _ = [p]
+
 splitData :: Closure -> Maybe (Reference, Word64, [Int], [Closure])
 splitData (Enum r t) = Just (r, t, [], [])
 splitData (DataU1 r t i) = Just (r, t, [i], [])
--- a/unison-src/transcripts-using-base/failure-tests.output.md
+++ b/unison-src/transcripts-using-base/failure-tests.output.md
@ -50,6 +50,10 @@ test2 = do
      (typeLink IOFailure)
      "Cannot decode byte '\\xee': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream"
      (Any ())
+  
+  
+  Stack trace:
+    ##raise

 ```
 ```ucm
@ -60,5 +64,9 @@ test2 = do
  The program halted with an unhandled exception:
  
    Failure (typeLink RuntimeFailure) "builtin.bug" (Any "whoa")
+  
+  
+  Stack trace:
+    ##raise

 ```
--- a/unison-src/transcripts-using-base/fix2027.output.md
+++ b/unison-src/transcripts-using-base/fix2027.output.md
@ -91,8 +91,9 @@ myServer = unsafeRun! '(hello "127.0.0.1" "0")
  
    Failure (typeLink IOFailure) "problem" (Any ())
  
-  I'm sorry this message doesn't have more detail about the
-  location of the failure. My makers plan to fix this in a
-  future release. 😢
+  
+  Stack trace:
+    bug
+    #dtd8ccth5f

 ```
--- a/unison-src/transcripts/io.output.md
+++ b/unison-src/transcripts/io.output.md
@ -604,6 +604,10 @@ Calling our examples with the wrong number of args will error.
  The program halted with an unhandled exception:
  
    Failure (typeLink IOFailure) "called with args" (Any ())
+  
+  
+  Stack trace:
+    ##raise

 ```
 ```ucm
@ -614,6 +618,10 @@ Calling our examples with the wrong number of args will error.
  The program halted with an unhandled exception:
  
    Failure (typeLink IOFailure) "called with no args" (Any ())
+  
+  
+  Stack trace:
+    ##raise

 ```
 ```ucm
@ -625,6 +633,10 @@ Calling our examples with the wrong number of args will error.
  
    Failure
      (typeLink IOFailure) "called with too many args" (Any ())
+  
+  
+  Stack trace:
+    ##raise

 ```
 ```ucm
@ -635,5 +647,9 @@ Calling our examples with the wrong number of args will error.
  The program halted with an unhandled exception:
  
    Failure (typeLink IOFailure) "called with no args" (Any ())
+  
+  
+  Stack trace:
+    ##raise

 ```
--- a/unison-src/transcripts/todo-bug-builtins.output.md
+++ b/unison-src/transcripts/todo-bug-builtins.output.md
@ -21,9 +21,10 @@
  
    "implement me later"
  
-  I'm sorry this message doesn't have more detail about the
-  location of the failure. My makers plan to fix this in a
-  future release. 😢
+  
+  Stack trace:
+    todo
+    #qe5e1lcfn8

 ```
 ```unison
@ -46,9 +47,10 @@
  
    "there's a bug in my code"
  
-  I'm sorry this message doesn't have more detail about the
-  location of the failure. My makers plan to fix this in a
-  future release. 😢
+  
+  Stack trace:
+    bug
+    #m67hcdcoda

 ```
 ## Todo
--- a/unison-src/transcripts/top-level-exceptions.output.md
+++ b/unison-src/transcripts/top-level-exceptions.output.md
@ -93,5 +93,9 @@ unique type RuntimeError =
  The program halted with an unhandled exception:
  
    Failure (typeLink RuntimeError) "oh noes!" (Any ())
+  
+  
+  Stack trace:
+    ##raise

 ```