WIP: ST example working (small bitmap stack frames)wip/ghc-debug-stack

12 files changed, 237 insertions, 21 deletions

diff --git a/ST.hs b/ST.hs
new file mode 100644
index 0000000000..6a235bcf1e
--- /dev/null
+++ b/ST.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import GHC.Exts.Heap
+import System.Mem
+
+main = foo 100
+
+loop 0 = foo 0
+loop n = print ("ITERATION", n) >> foo n >> loop (n-1)
+
+{-# NOINLINE foo #-}
+foo 0 = () <$ getStack
+foo n = print "x" >> foo (n - 1) >> print "x"
+
+getStack = do
+  fs <- getCurrentStackData
+  print fs
+  getLine
+  print (length fs)
+  getLine
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index ea682702c6..57ca757d3f 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/compiler/GHC/Runtime/Heap/Inspect.hs
@@ -62,6 +62,7 @@ import GHC.Utils.Outputable as Ppr
 import GHC.Utils.Panic
 import GHC.Char
 import GHC.Exts.Heap
+import GHC.Exts.Heap.InfoTable.Types
 import GHC.Runtime.Heap.Layout ( roundUpTo )
 import GHC.IO (throwIO)
 
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index b11ade6246..51a155ab13 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 {-|
 Module      :  GHC.Exts.Heap
@@ -34,7 +35,10 @@ module GHC.Exts.Heap (
     , getClosureDataFromHeapRep
 
     -- * Info Table types
-    , StgInfoTable(..)
+    , StgInfoTable_(..)
+    , StgInfoTable
+    , StgStackInfoTable
+    , Layout(..)
     , EntryFunPtr
     , HalfWord
     , ItblCodes
@@ -56,8 +60,12 @@ module GHC.Exts.Heap (
     , Box(..)
     , asBox
     , areBoxesEqual
+
+    -- * Stacks
+    , getCurrentStackData
     ) where
 
+
 import Prelude
 import GHC.Exts.Heap.Closures
 import GHC.Exts.Heap.ClosureTypes
@@ -69,6 +77,7 @@ import GHC.Exts.Heap.InfoTableProf
 import GHC.Exts.Heap.InfoTable
 #endif
 import GHC.Exts.Heap.Utils
+import GHC.Stack.CloneStack
 import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
 
 import Control.Monad
@@ -76,6 +85,7 @@ import Data.Bits
 import Foreign
 import GHC.Exts
 import GHC.Int
+import GHC.IO(IO(..))
 import GHC.Word
 
 #include "ghcconfig.h"
@@ -385,3 +395,17 @@ getClosureDataFromHeapRep decodeStackClosures heapRep infoTablePtr pts = do
 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
 getBoxedClosureData :: Box -> IO Closure
 getBoxedClosureData (Box a) = getClosureData a
+
+getCurrentStackData :: IO [FFIClosures.StackFrame]
+getCurrentStackData = do
+  StackSnapshot stack_snapshot <- cloneMyStack
+  let stack_addr :: Ptr () = Ptr (unsafeCoerce# stack_snapshot)
+  res <- FFIClosures.peekStack stack_addr
+  IO (\s -> case touch# stack_snapshot s of
+                s' -> (# s', () #) )
+  return res
+
+
+
+
+
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
index 57fcd3796e..4eb8c54348 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
 
 module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
 
@@ -15,7 +17,10 @@ import Foreign
 import GHC.Exts
 import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
 import GHC.Exts.Heap.ProfInfo.Types
-import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
+import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..), Box(..))
+import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.InfoTable
+import GHC.Exts.Heap.Constants
 
 data TSOFields = TSOFields {
     tso_what_next :: WhatNext,
@@ -107,8 +112,9 @@ data StackFields = StackFields {
 #if __GLASGOW_HASKELL__ >= 810
     stack_marking :: Word8,
 #endif
-    stack_sp :: Addr##
-}
+    stack_sp :: Ptr (),
+    stack_stack :: Ptr ()
+} deriving Show
 
 -- | Get non-closure fields from @StgStack_@ (@TSO.h@)
 peekStackFields :: Ptr a -> IO StackFields
@@ -119,6 +125,7 @@ peekStackFields ptr = do
     marking' <- (#peek struct StgStack_, marking) ptr
 #endif
     Ptr sp' <- (#peek struct StgStack_, sp) ptr
+    Ptr stack <- (#peek struct StgStack_, stack) ptr
 
     -- TODO decode the stack.
 
@@ -128,6 +135,82 @@ peekStackFields ptr = do
 #if __GLASGOW_HASKELL__ >= 810
         stack_marking = marking',
 #endif
-        stack_sp = sp'
+        stack_sp = Ptr sp',
+        stack_stack = Ptr stack
     }
 
+
+data GenStackFrame c = StackFrame StgStackInfoTable (GenStackPayload c) deriving Show
+
+type StackFrame = GenStackFrame Box
+
+data GenStackPayload c = StackPayload [PointerOrData c] deriving Show
+
+peekStack :: Ptr a -> IO [StackFrame]
+peekStack p = do
+  print p
+  fields <- peekStackFields p
+  print fields
+  print (startStack p)
+  let end = (startStack p `plusPtr` (8 * (fromIntegral $ stack_size fields)))
+  print end
+  print (stack_sp fields >= end)
+  print (stack_sp fields `minusPtr` end)
+  stackWorker (castPtr p) (stack_sp fields) end
+
+startStack = (#ptr StgStack, stack)
+
+--peekStackFrame :: Ptr a -> IO StackFrame
+--peekStackFrame = _
+
+stackWorker :: Ptr () -> Ptr a -> Ptr a -> IO [StackFrame]
+stackWorker c stackStart stackEnd
+  | stackStart >= stackEnd = return []
+  | otherwise = do
+      print ("start", stackStart)
+      print ("togo", stackStart `minusPtr` stackEnd)
+      -- StgRetInfoTable
+      itblPtr <- (#peek struct StgClosure_, header.info) stackStart
+      print ("itblPtr", itblPtr `plusPtr` (2 * negate wORD_SIZE))
+
+      let itblPtr' = itblPtr `plusPtr` (2 * negate wORD_SIZE)
+      (ty :: HalfWord) <- ((#peek StgRetInfoTable, i.type) itblPtr')
+      print ty
+      itbl <- peekStackItbl ((#ptr StgRetInfoTable, i) itblPtr')
+      print ("itbl", itbl)
+      (ps, next) <-
+        case tipe itbl of
+          STOP_FRAME -> small_bitmap stackStart itbl
+          CATCH_FRAME -> small_bitmap stackStart itbl
+          CATCH_STM_FRAME -> small_bitmap stackStart itbl
+          CATCH_RETRY_FRAME -> small_bitmap stackStart itbl
+          ATOMICALLY_FRAME -> small_bitmap stackStart itbl
+          RET_SMALL -> small_bitmap stackStart itbl
+          _ -> getLine >> undefined
+      print ps
+      print next
+      more_frames <- stackWorker c next stackEnd
+      return $ (StackFrame itbl (StackPayload ps)) : more_frames
+  where
+    small_bitmap start itbl = do
+      let BM pords = layout itbl
+      collectPointers (start `plusPtr` wORD_SIZE) pords
+
+    collectPointers :: Ptr a -> [PointerOrData ()] -> IO ([PointerOrData Box], Ptr a)
+    collectPointers p [] = return ([], p)
+    collectPointers p (pord:pords) = do
+      (pord', p') <- collectPointer p pord
+      (xs, p'') <- collectPointers p' pords
+      return $ (pord' : xs, p'')
+
+    collectPointer :: Ptr a -> PointerOrData () -> IO (PointerOrData Box, Ptr a)
+    collectPointer p pord = do
+      pord' <- traverse (const (pointerPtrToBox (castPtr p))) pord
+      return (pord', p `plusPtr` (wORD_SIZE))
+
+
+    pointerPtrToBox :: Ptr (Ptr a) -> IO Box
+    pointerPtrToBox p = do
+      Ptr p' <- peek p
+      return (Box (unsafeCoerce## p'))
+
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
index c700921465..d6e8fa89e3 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
@@ -1,7 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
 module GHC.Exts.Heap.InfoTable
     ( module GHC.Exts.Heap.InfoTable.Types
     , itblSize
     , peekItbl
+    , peekStackItbl
     , pokeItbl
     ) where
 
@@ -14,6 +16,8 @@ import GHC.Exts.Heap.Constants
 import Data.Maybe
 #endif
 import Foreign
+import Debug.Trace
+
 
 -------------------------------------------------------------------------
 -- Profiling specific code
@@ -41,8 +45,7 @@ peekItbl a0 = do
   srtlen' <- (#peek struct StgInfoTable_, srt) a0
   return StgInfoTable
     { entry  = entry'
-    , ptrs   = ptrs'
-    , nptrs  = nptrs'
+    , layout = Payload ptrs' nptrs'
     , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
     , srtlen = srtlen'
     , code   = Nothing
@@ -53,8 +56,8 @@ pokeItbl a0 itbl = do
 #if !defined(TABLES_NEXT_TO_CODE)
   (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
 #endif
-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs (layout itbl))
+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs (layout itbl))
   (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))
   (#poke StgInfoTable, srt) a0 (srtlen itbl)
 #if defined(TABLES_NEXT_TO_CODE)
@@ -71,3 +74,40 @@ pokeItbl a0 itbl = do
 -- | Size in bytes of a standard InfoTable
 itblSize :: Int
 itblSize = (#size struct StgInfoTable_)
+
+peekStackItbl :: Ptr StgInfoTable -> IO StgStackInfoTable
+peekStackItbl a0 = do
+#if !defined(TABLES_NEXT_TO_CODE)
+  let ptr = a0 `plusPtr` (negate wORD_SIZE)
+  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
+#else
+  let ptr = a0
+      entry' = Nothing
+#endif
+  bitmap'   <- (#peek StgRetInfoTable, i.layout.bitmap) ptr
+  tipe'   <- (#peek StgRetInfoTable, i.type) ptr
+  srtlen' <- (#peek StgRetInfoTable, i.srt) a0
+  return StgInfoTable
+    { entry  = entry'
+    , layout   = BM (bitmapBits bitmap')
+    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
+    , srtlen = srtlen'
+    , code   = Nothing
+    }
+
+
+bitmapSize ::  Word -> Int
+bitmapSize w = fromIntegral (w .&. bITMAP_SIZE_MASK)
+
+bITMAP_SIZE_MASK :: Word
+bITMAP_SIZE_MASK = 0x3f
+bITMAP_BITS_SHIFT :: Int
+bITMAP_BITS_SHIFT = 6
+
+-- True = Pointer
+-- False = Data
+bitmapBits :: Word -> [PointerOrData ()]
+bitmapBits w = reverse (map (toPointerOrData . testBit bs) [0..k-1])
+  where
+    k = traceShowId (bitmapSize w)
+    bs = w `shiftR` bITMAP_BITS_SHIFT
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
index 943a234391..02d3192815 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
@@ -1,6 +1,19 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
 module GHC.Exts.Heap.InfoTable.Types
-    ( StgInfoTable(..)
+    ( StgInfoTable_(..)
+    , StgInfoTable
+    , StgStackInfoTable
+    , PointerOrData(..)
+    , toPointerOrData
+    , Layout(..)
     , EntryFunPtr
     , HalfWord
     , ItblCodes
@@ -27,14 +40,30 @@ type HalfWord = Word16
 
 type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
 
+data LayoutType = Pointers | Bitmap | LargeBitmap
+
+data Layout (a :: LayoutType) where
+  Payload :: { ptrs :: HalfWord, nptrs :: HalfWord } -> Layout Pointers
+  BM :: [PointerOrData ()] -> Layout Bitmap
+
+data PointerOrData p = Pointer p | Data deriving (Show, Traversable, Foldable, Functor)
+
+toPointerOrData :: Bool -> PointerOrData ()
+toPointerOrData True = Pointer ()
+toPointerOrData False = Data
+
+deriving instance Show (Layout a)
+
 -- | This is a somewhat faithful representation of an info table. See
 -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/InfoTables.h>
 -- for more details on this data structure.
-data StgInfoTable = StgInfoTable {
+data StgInfoTable_ a = StgInfoTable {
    entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
-   ptrs   :: HalfWord,
-   nptrs  :: HalfWord,
+   layout :: Layout a,
    tipe   :: ClosureType,
    srtlen :: HalfWord,
    code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
   } deriving (Show, Generic)
+
+type StgInfoTable = StgInfoTable_ Pointers
+type StgStackInfoTable = StgInfoTable_ Bitmap
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc
index ded386bb8d..dd7d868242 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc
@@ -38,8 +38,7 @@ peekItbl a0 = do
   srtlen' <- (#peek struct StgInfoTable_, srt) a0
   return StgInfoTable
     { entry  = entry'
-    , ptrs   = ptrs'
-    , nptrs  = nptrs'
+    , layout = Payload ptrs' nptrs'
     , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
     , srtlen = srtlen'
     , code   = Nothing
@@ -50,8 +49,8 @@ pokeItbl a0 itbl = do
 #if !defined(TABLES_NEXT_TO_CODE)
   (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
 #endif
-  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
-  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs (layout itbl))
+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs (layout itbl))
   (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))
   (#poke StgInfoTable, srt) a0 (srtlen itbl)
 #if defined(TABLES_NEXT_TO_CODE)
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index b3f3c16332..b4dfb0e577 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -20,6 +20,7 @@ import Foreign.C
 import GHC.Ptr
 import GHC.Exts
 import GHC.Exts.Heap
+import GHC.Exts.Heap.InfoTable.Types
 import Data.ByteString (ByteString)
 import Control.Monad.Fail
 import qualified Data.ByteString as BS
@@ -48,8 +49,8 @@ mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc =
                  entry = if tables_next_to_code
                          then Nothing
                          else Just entry_addr,
-                 ptrs  = fromIntegral ptr_words,
-                 nptrs = fromIntegral nonptr_words,
+                 layout  = Payload (fromIntegral ptr_words)
+                                   (fromIntegral nonptr_words),
                  tipe  = CONSTR,
                  srtlen = fromIntegral tag,
                  code  = code'
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index d21686a326..05874dcc7f 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -31,6 +31,7 @@ import GHCi.BreakArray
 
 import GHC.LanguageExtensions
 import qualified GHC.Exts.Heap as Heap
+import qualified GHC.Exts.Heap.InfoTable.Types as Heap
 import GHC.ForeignSrcLang
 import GHC.Fingerprint
 import Control.Concurrent
@@ -460,7 +461,11 @@ instance Binary Heap.WhyBlocked
 instance Binary Heap.TsoFlags
 #endif
 
-instance Binary Heap.StgInfoTable
+instance Binary (Heap.StgInfoTable_ a)
+instance Binary (Heap.Layout a) where
+  put = undefined
+  get = undefined
+  -- TODO
 instance Binary Heap.ClosureType
 instance Binary Heap.PrimType
 instance Binary a => Binary (Heap.GenClosure a)
diff --git a/rts/CloneStack.c b/rts/CloneStack.c
index a820cb8da3..da447d36dc 100644
--- a/rts/CloneStack.c
+++ b/rts/CloneStack.c
@@ -18,10 +18,12 @@
 
 #if defined(DEBUG)
 #include "sm/Sanity.h"
+#include "Printer.h"
 #endif
 
 static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack)
 {
+  printf("CLONE_STACK_CHUNK");
   StgWord spOffset = stack->sp - stack->stack;
   StgWord closureSizeBytes = sizeof(StgStack) + (stack->stack_size * sizeof(StgWord));
 
@@ -29,12 +31,20 @@ static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack)
 
   memcpy(newStackClosure, stack, closureSizeBytes);
 
+  printf("spOffset: %d", spOffset);
+  debugBelch("spOffset: %d", spOffset);
+  debugBelch("sp: %p\n", stack->sp);
+  debugBelch("sp: %p\n", stack->stack);
+  debugBelch("sp: %p\n", newStackClosure->stack);
   newStackClosure->sp = newStackClosure->stack + spOffset;
   // The new stack is not on the mutable list; clear the dirty flag such that
   // we don't claim that it is.
   newStackClosure->dirty = 0;
 
 #if defined(DEBUG)
+  printStack(stack);
+  checkClosure((StgClosure*) stack);
+  printStack(newStackClosure);
   checkClosure((StgClosure*) newStackClosure);
 #endif
 
@@ -44,6 +54,7 @@ static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack)
 StgStack* cloneStack(Capability* capability, const StgStack* stack)
 {
   StgStack *top_stack = cloneStackChunk(capability, stack);
+  debugBelch("COPIED TOP: %p", stack);
   StgStack *last_stack = top_stack;
   while (true) {
     // check whether the stack ends in an underflow frame
@@ -51,6 +62,8 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack)
     StgUnderflowFrame *underFlowFrame = ((StgUnderflowFrame *) top);
     StgUnderflowFrame *frame = underFlowFrame--;
     if (frame->info == &stg_stack_underflow_frame_info) {
+      printf("HAS UNDERFLOW");
+      debugBelch("COPying UNDERFLOW: %p", frame->next_chunk);
       StgStack *s = cloneStackChunk(capability, frame->next_chunk);
       frame->next_chunk = s;
       last_stack = s;
diff --git a/rts/Printer.c b/rts/Printer.c
index 729c8067b8..7a9efc86f1 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -642,7 +642,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
     }
 }
 
-static void printStack( StgStack *stack )
+void printStack( StgStack *stack )
 {
     printStackChunk( stack->sp, stack->stack + stack->stack_size );
 }
diff --git a/rts/Printer.h b/rts/Printer.h
index 44c55de3d6..7dc6dca353 100644
--- a/rts/Printer.h
+++ b/rts/Printer.h
@@ -23,6 +23,7 @@ const char  *      info_update_frame ( const StgClosure *closure );
 #if defined(DEBUG)
 extern void        printClosure    ( const StgClosure *obj );
 extern void        printStackChunk ( StgPtr sp, StgPtr spLim );
+extern void        printStack      ( StgStack *stack);
 extern void        printTSO        ( StgTSO *tso );
 extern void        printMutableList( bdescr *bd );
 extern void        printStaticObjects ( StgClosure *obj );