Enable stack traces with ghci -fexternal-interpreter -prof

Summary:
The main goal here is enable stack traces in GHCi.  After this change,
if you start GHCi like this:

  ghci -fexternal-interpreter -prof

(which requires packages to be built for profiling, but not GHC
itself) then the interpreter manages cost-centre stacks during
execution and can produce a stack trace on request.  Call locations
are available for all interpreted code, and any compiled code that was
built with the `-fprof-auto` familiy of flags.

There are a couple of ways to get a stack trace:

* `error`/`undefined` automatically get one attached
* `Debug.Trace.traceStack` can be used anywhere, and prints the current
  stack

Because the interpreter is running in a separate process, only the
interpreted code is running in profiled mode and the compiler itself
isn't slowed down by profiling.

The GHCi debugger still doesn't work with -fexternal-interpreter,
although this patch gets it a step closer.  Most of the functionality
of breakpoints is implemented, but the runtime value introspection is
still not supported.

Along the way I also did some refactoring and added type arguments to
the various remote pointer types in `GHCi.RemotePtr`, so there's
better type safety and documentation in the bridge code between GHC
and ghc-iserv.

Test Plan: validate

Reviewers: bgamari, ezyang, austin, hvr, goldfire, erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1747

GHC Trac Issues: #11047, #11100

1 files changed, 22 insertions, 21 deletions

diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index aa92ecc610..74f490b8fd 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -22,6 +22,7 @@ module ByteCodeLink (
 import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
 import GHCi.InfoTable
+import GHCi.BreakArray
 import SizedSeq
 
 import GHCi
@@ -60,15 +61,16 @@ extendClosureEnv cl_env pairs
 -}
 
 linkBCO
-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  -> UnlinkedBCO
   -> IO ResolvedBCO
-linkBCO hsc_env ie ce bco_ix
+linkBCO hsc_env ie ce bco_ix breakarray
            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0)
-  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix) (ssElts ptrs0)
+  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
   return (ResolvedBCO arity insns bitmap
-            (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
-            (addListToSS emptySS ptrs))
+              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+              (addListToSS emptySS ptrs))
 
 lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
 lookupLiteral _ _ (BCONPtrWord lit) = return lit
@@ -79,7 +81,7 @@ lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do
   Ptr a# <- lookupIE hsc_env ie nm
   return (W# (int2Word# (addr2Int# a#)))
 lookupLiteral hsc_env _ (BCONPtrStr bs) = do
-  fromIntegral . ptrToWordPtr <$> mallocData hsc_env bs
+  fromIntegral . ptrToWordPtr . fromRemotePtr <$> mallocData hsc_env bs
 
 lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
 lookupStaticPtr hsc_env addr_of_label_string = do
@@ -89,26 +91,26 @@ lookupStaticPtr hsc_env addr_of_label_string = do
     Nothing  -> linkFail "ByteCodeLink: can't find label"
                   (unpackFS addr_of_label_string)
 
-lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a)
+lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
 lookupIE hsc_env ie con_nm =
   case lookupNameEnv ie con_nm of
-    Just (_, ItblPtr a) -> return (castPtr (conInfoPtr a))
+    Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
     Nothing -> do -- try looking up in the object files.
        let sym_to_find1 = nameToCLabel con_nm "con_info"
        m <- lookupSymbol hsc_env sym_to_find1
        case m of
-          Just addr -> return (castPtr addr)
+          Just addr -> return addr
           Nothing
              -> do -- perhaps a nullary constructor?
                    let sym_to_find2 = nameToCLabel con_nm "static_info"
                    n <- lookupSymbol hsc_env sym_to_find2
                    case n of
-                      Just addr -> return (castPtr addr)
+                      Just addr -> return addr
                       Nothing   -> linkFail "ByteCodeLink.lookupIE"
                                       (unpackFS sym_to_find1 ++ " or " ++
                                        unpackFS sym_to_find2)
 
-lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr
+lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())
 lookupPrimOp hsc_env primop = do
   let sym_to_find = primopToCLabel primop "closure"
   m <- lookupSymbol hsc_env (mkFastString sym_to_find)
@@ -117,13 +119,14 @@ lookupPrimOp hsc_env primop = do
     Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
 
 resolvePtr
-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
+  -> BCOPtr
   -> IO ResolvedBCOPtr
-resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
+resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
   | Just ix <- lookupNameEnv bco_ix nm =
     return (ResolvedBCORef ix) -- ref to another BCO in this group
   | Just (_, rhv) <- lookupNameEnv ce nm =
-    return (ResolvedBCOPtr (unsafeForeignHValueToHValueRef rhv))
+    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
   | otherwise =
     ASSERT2(isExternalName nm, ppr nm)
     do let sym_to_find = nameToCLabel nm "closure"
@@ -131,14 +134,12 @@ resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
        case m of
          Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
          Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
-resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) =
+resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
   ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
-resolvePtr hsc_env ie ce bco_ix (BCOPtrBCO bco) =
-  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix bco
-resolvePtr _ _ _ _ (BCOPtrBreakInfo break_info) =
-  return (ResolvedBCOPtrLocal (unsafeCoerce# break_info))
-resolvePtr _ _ _ _ (BCOPtrArray break_array) =
-  return (ResolvedBCOPtrLocal (unsafeCoerce# break_array))
+resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
+  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
+resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
+  return (ResolvedBCOPtrBreakArray breakarray)
 
 linkFail :: String -> String -> IO a
 linkFail who what