[Git][ghc/ghc][wip/decode_cloned_stack] 3 commits: Safer Eq StackSnapshot

[Sven Tennie (@supersven)]

Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC


Commits:
efc98054 by Sven Tennie at 2023-02-05T15:00:47+00:00
Safer Eq StackSnapshot

- - - - -
8704428f by Sven Tennie at 2023-02-05T15:09:45+00:00
Revert useless changes

- - - - -
02ec1349 by Sven Tennie at 2023-02-05T17:03:23+00:00
Revert unnecessary changes

- - - - -


5 changed files:

- libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/cbits/StackCloningDecoding.cmm
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
- rts/Heap.c
- rts/PrimOps.cmm


Changes:

=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -50,7 +50,7 @@ stackSnapshotToWord :: StackSnapshot -> Word
 stackSnapshotToWord (StackSnapshot s#) = W# (stackSnapshotToWord# s#)
 
 instance Eq StackSnapshot where
-  s1 == s2 = stackSnapshotToWord s1 == stackSnapshotToWord s2
+  (StackSnapshot s1#) == (StackSnapshot s2#) = (W# (eqStacks# s1# s2#)) > 0
 
 foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #)
 
@@ -60,6 +60,8 @@ foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: Thre
 
 foreign import prim "stackSnapshotToWordzh" stackSnapshotToWord# :: StackSnapshot# -> Word#
 
+foreign import prim "eqStackszh" eqStacks# :: StackSnapshot# -> StackSnapshot# -> Word#
+
 {-
 Note [Stack Cloning]
 ~~~~~~~~~~~~~~~~~~~~


=====================================
libraries/base/cbits/StackCloningDecoding.cmm
=====================================
@@ -29,3 +29,7 @@ stg_decodeStackzh (gcptr stgStack) {
 stackSnapshotToWordzh(P_ stack) {
   return (stack);
 }
+
+eqStackszh(P_ stack1, P_ stack2) {
+  return (stack1 == stack2);
+}


=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc
=====================================
@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MagicHash #-}
-{-# LANGUAGE BangPatterns #-}
 
 module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
 
@@ -15,7 +14,6 @@ import GHC.Exts
 import GHC.Exts.Heap.ProfInfo.PeekProfInfo
 import GHC.Exts.Heap.ProfInfo.Types
 import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
-import Numeric
 
 data TSOFields = TSOFields {
     tso_what_next :: WhatNext,
@@ -104,11 +102,10 @@ data StackFields = StackFields {
 #if __GLASGOW_HASKELL__ >= 811
     stack_marking :: Word8,
 #endif
-    stack_sp :: Addr##,
-    stack_stack :: Addr##
+    stack_sp :: Addr##
 }
 
--- | Get fields from @StgStack_@ (@TSO.h@)
+-- | Get non-closure fields from @StgStack_@ (@TSO.h@)
 peekStackFields :: Ptr a -> IO StackFields
 peekStackFields ptr = do
     stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32
@@ -117,7 +114,8 @@ peekStackFields ptr = do
     marking' <- (#peek struct StgStack_, marking) ptr
 #endif
     Ptr sp' <- (#peek struct StgStack_, sp) ptr
-    let !(Ptr stack') = (#ptr struct StgStack_, stack) ptr
+
+    -- TODO decode the stack.
 
     return StackFields {
         stack_size = stack_size',
@@ -125,9 +123,6 @@ peekStackFields ptr = do
 #if __GLASGOW_HASKELL__ >= 811
         stack_marking = marking',
 #endif
-        stack_sp = sp',
-        stack_stack = stack'
+        stack_sp = sp'
     }
 
-showAddr## :: Addr## -> String
-showAddr## addr## = (showHex $ I## (addr2Int## addr##)) ""


=====================================
rts/Heap.c
=====================================
@@ -12,7 +12,6 @@
 
 #include "Capability.h"
 #include "Printer.h"
-#include "rts/storage/InfoTables.h"
 
 StgWord heap_view_closureSize(StgClosure *closure) {
     ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
@@ -257,6 +256,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) {
 
 StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
     ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
     StgWord size = heap_view_closureSize(closure);
 
     // First collect all pointers here, with the comfortable memory bound


=====================================
rts/PrimOps.cmm
=====================================
@@ -2513,6 +2513,7 @@ stg_unpackClosurezh ( P_ closure )
 
     W_ clos;
     clos = UNTAG(closure);
+
     W_ len;
     // The array returned, dat_arr, is the raw data for the entire closure.
     // The length is variable based upon the closure type, ptrs, and non-ptrs



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae0d6694b68983c7b4b098451e2b59a466ec8cd4...02ec1349dd711c4623a041ad0afef90b121d5bee

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae0d6694b68983c7b4b098451e2b59a466ec8cd4...02ec1349dd711c4623a041ad0afef90b121d5bee
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230205/8c432959/attachment-0001.html>