[Git][ghc/ghc][wip/ghc-debug] Check pointers with pattern matching (#18405)

[Sven Tennie]

Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC


Commits:
4e120fab by Sven Tennie at 2020-08-26T13:37:07+02:00
Check pointers with pattern matching (#18405)

This is nicer than to check the length of the pointer's list and index
on it.

- - - - -


1 changed file:

- libraries/ghc-heap/GHC/Exts/Heap.hs


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -346,55 +346,48 @@ getClosureX get_closure_raw x = do
                 , finalizer = pts !! 3
                 , link = pts !! 4
                 }
-        TSO -> do
-            unless (length pts == 6) $
-                fail $ "Expected 6 ptr arguments to TSO, found "
+        TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
+                -> withArray wds (\ptr -> do
+                    fields <- FFIClosures.peekTSOFields peekStgTSOProfInfo ptr
+                    pure $ TSOClosure
+                        { info = itbl
+                        , unsafe_link = u_lnk
+                        , unsafe_global_link = u_gbl_lnk
+                        , tsoStack = tso_stack
+                        , unsafe_trec = u_trec
+                        , unsafe_blocked_exceptions = u_blk_ex
+                        , unsafe_bq = u_bq
+                        , what_next = FFIClosures.tso_what_next fields
+                        , why_blocked = FFIClosures.tso_why_blocked fields
+                        , flags = FFIClosures.tso_flags fields
+                        , threadId = FFIClosures.tso_threadId fields
+                        , saved_errno = FFIClosures.tso_saved_errno fields
+                        , tso_dirty = FFIClosures.tso_dirty fields
+                        , alloc_limit = FFIClosures.tso_alloc_limit fields
+                        , tot_stack_size = FFIClosures.tso_tot_stack_size fields
+                        , prof = FFIClosures.tso_prof fields
+                        })
+            | otherwise
+                -> fail $ "Expected 6 ptr arguments to TSO, found "
                         ++ show (length pts)
-
-            allocaArray (length wds) (\ptr -> do
-                pokeArray ptr wds
-
-                fields <- FFIClosures.peekTSOFields peekStgTSOProfInfo ptr
-                pure $ TSOClosure
-                    { info = itbl
-                    , unsafe_link = (pts !! 0)
-                    , unsafe_global_link = (pts !! 1)
-                    , tsoStack = (pts !! 2)
-                    , unsafe_trec = (pts !! 3)
-                    , unsafe_blocked_exceptions = (pts !! 4)
-                    , unsafe_bq = (pts !! 5)
-                    , what_next = FFIClosures.tso_what_next fields
-                    , why_blocked = FFIClosures.tso_why_blocked fields
-                    , flags = FFIClosures.tso_flags fields
-                    , threadId = FFIClosures.tso_threadId fields
-                    , saved_errno = FFIClosures.tso_saved_errno fields
-                    , tso_dirty = FFIClosures.tso_dirty fields
-                    , alloc_limit = FFIClosures.tso_alloc_limit fields
-                    , tot_stack_size = FFIClosures.tso_tot_stack_size fields
-                    , prof = FFIClosures.tso_prof fields
-                    }
-                )
-        STACK -> do
-            unless (length pts == 1) $
-                fail $ "Expected 1 ptr argument to STACK, found "
-                        ++ show (length pts)
-
-            allocaArray (length wds) (\ptr -> do
-                pokeArray ptr wds
-
-                fields <- FFIClosures.peekStackFields ptr
-
-                pure $ StackClosure
-                    { info = itbl
-                    , stack_size = FFIClosures.stack_size fields
-                    , stack_dirty = FFIClosures.stack_dirty fields
-                    , unsafeStackPointer = (pts !! 0)
-                    , unsafeStack  = FFIClosures.stack fields
+        STACK   | [u_sp] <- pts
+                    -> withArray wds (\ptr -> do
+                            fields <- FFIClosures.peekStackFields ptr
+
+                            pure $ StackClosure
+                                { info = itbl
+                                , stack_size = FFIClosures.stack_size fields
+                                , stack_dirty = FFIClosures.stack_dirty fields
+                                , unsafeStackPointer = u_sp
+                                , unsafeStack  = FFIClosures.stack fields
 #if __GLASGOW_HASKELL__ >= 811
-                    , stack_marking = FFIClosures.stack_marking fields
+                                , stack_marking = FFIClosures.stack_marking fields
 #endif
-                    }
-                )
+                                })
+                | otherwise
+                    -> fail $ "Expected 1 ptr argument to STACK, found "
+                        ++ show (length pts)
+
         _ ->
             pure $ UnsupportedClosure itbl
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e120fab41432d16679eeb3eba07a5b4156f3739

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e120fab41432d16679eeb3eba07a5b4156f3739
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/20200826/cb084125/attachment-0001.html>