Convert XException to ErrorCall

To make it easier to report XException when `pack` would normally
hide them.

clash-ghc/src-ghc/Clash/GHC/GHC2Core.hs

@@ -364,6 +364,9 @@ coreToTerm primMap unlocs = term
         go "Clash.Magic.noDeDup" args
           | [_aTy,f] <- args
           = C.Tick C.NoDeDup <$> term f
+        go "Clash.XException.xToErrorCtx" args   -- xToError :: forall a. String -> a -> a
+          | [_ty, _msg, x] <- args
+          = term x
         go nm args
           | Just n <- parseBundle "bundle" nm
             -- length args = domain tyvar + signal arg + number of type vars
@@ -491,6 +494,8 @@ coreToTerm primMap unlocs = term
               -> return (nameModTerm C.SuffixName xType)
               | f == "Clash.Magic.setName"
               -> return (nameModTerm C.SetName xType)
+              | f == "Clash.XException.xToErrorCtx"
+              -> return (xToErrorCtxTerm xType)
               | otherwise                                    -> return (C.Prim (C.PrimInfo xNameS xType wi))
             Just (Just (BlackBox {workInfo = wi})) ->
               return $ C.Prim (C.PrimInfo xNameS xType wi)
@@ -1328,6 +1333,34 @@ nameModTerm sa (C.ForAllTy nmTV (C.ForAllTy aTV funTy)) =
 
 nameModTerm _ ty = error $ $(curLoc) ++ show ty
 
+
+-- | Given the type:
+--
+-- @forall (a :: Type) . String -> a -> a@
+--
+-- Generate the term:
+--
+-- @/\(a:Type).\(ctx:String).\(x:a) -> <TICK>x@
+xToErrorCtxTerm
+  :: C.Type
+  -> C.Term
+xToErrorCtxTerm (C.ForAllTy aTV funTy) =
+  C.TyLam aTV (
+  C.Lam ctxId (
+  C.Lam xId (
+  C.Var xId)))
+  where
+    (C.FunTy ctxTy rTy) = C.tyView funTy
+    (C.FunTy xTy _)     = C.tyView rTy
+    -- Safe to use `mkUnsafeSystemName` here, because we're building the
+    -- identity \x.x, so any shadowing of 'x' would be the desired behavior.
+    ctxName          = C.mkUnsafeSystemName "ctx" 0
+    ctxId            = C.mkLocalId ctxTy ctxName
+    xName            = C.mkUnsafeSystemName "x" 1
+    xId              = C.mkLocalId xTy xName
+
+xToErrorCtxTerm ty = error $ $(curLoc) ++ show ty
+
 isDataConWrapId :: Id -> Bool
 isDataConWrapId v = case idDetails v of
   DataConWrapId {} -> True

clash-lib/prims/common/Clash_XException.json

@@ -30,4 +30,9 @@
      , "template"  : "~DEVNULL[~VAR[x][0]]~ARG[1]"
      }
   }
+, { "Primitive" :
+    { "name"      : "Clash.XException.xToErrorCtx"
+    , "primType"  : "Function"
+    }
+  }
 ]

clash-prelude/src/Clash/XException.hs

@@ -31,7 +31,7 @@ CallStack (from HasCallStack):
 
 module Clash.XException
   ( -- * 'X': An exception for uninitialized values
-    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX, fromJustX, undefined
+    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX, fromJustX, undefined, xToErrorCtx
     -- * Printing 'X' exceptions as \"X\"
   , ShowX (..), showsX, printX, showsPrecXWith
     -- * Strict evaluation
@@ -46,7 +46,8 @@ import           Prelude             hiding (undefined)
 import           Clash.Annotations.Primitive (hasBlackBox)
 import           Clash.CPP           (maxTupleSize, fSuperStrict)
 import           Clash.XException.TH
-import           Control.Exception   (Exception, catch, evaluate, throw)
+import           Control.Exception
+  (ErrorCall (..), Exception, catch, evaluate, throw)
 import           Control.DeepSeq     (NFData, rnf)
 import           Data.Complex        (Complex)
 import           Data.Either         (isLeft)
@@ -99,6 +100,36 @@ infixr 0 `defaultSeqX`
 errorX :: HasCallStack => String -> a
 errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack))
 
+-- | Convert 'XException' to 'ErrorCall'
+--
+-- This is useful when tracking the source of 'XException' that gets eaten up by
+-- 'Clash.Classes.BitPack.pack' inside of your circuit; since
+-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.
+--
+-- So for example if you have some large function f:
+--
+-- > f a b = ... pack a ... pack b ...
+--
+-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',
+-- and so you want that to be reported the moment /a/ or /b/ is used, instead of
+-- it being thrown when evaluating the result of /f/, then do:
+--
+-- > {-# LANGUAGE ViewPatterns #-}
+-- > f (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = ...
+--
+-- Where we pass an extra string, for context, to know which argument evaluated
+-- to an 'XException'. We can also use BangPatterns to report the potential
+-- 'XException' being thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:
+--
+-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}
+-- > f (xToErrorCtx "a is X" -> !a) (xToErrorCtx "b is X" -> !b) = ...
+--
+-- __NB:__ Fully synthesisable, so doesn't have to be removed before synthesis
+xToErrorCtx :: String -> a -> a
+xToErrorCtx ctx a = unsafeDupablePerformIO
+  (catch (evaluate a >> return a) (\(XException msg) -> throw (ErrorCall (ctx <> "\n" <> msg))))
+{-# NOINLINE xToErrorCtx #-}
+
 -- | Like 'seq', however, whereas 'seq' will always do:
 --
 -- > seq  _|_              b = _|_