diff --git a/GHC/Exts/Heap.hs b/GHC/Exts/Heap.hs --- a/GHC/Exts/Heap.hs +++ b/GHC/Exts/Heap.hs @@ -3,7 +3,8 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnliftedFFITypes #-} @@ -70,7 +71,6 @@ import qualified GHC.Exts.Heap.FFIClosures as FFIClosures import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI -import Control.Monad import Data.Bits import Foreign import GHC.Exts @@ -220,136 +220,120 @@ t | t >= THUNK && t <= THUNK_STATIC -> do pure $ ThunkClosure itbl pts npts - THUNK_SELECTOR -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to THUNK_SELECTOR" - pure $ SelectorClosure itbl (head pts) + THUNK_SELECTOR -> case pts of + [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR" + hd : _ -> pure $ SelectorClosure itbl hd t | t >= FUN && t <= FUN_STATIC -> do pure $ FunClosure itbl pts npts - AP -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to AP" - -- We expect at least the arity, n_args, and fun fields - unless (length payloadWords >= 2) $ - fail "Expected at least 2 raw words to AP" - let splitWord = payloadWords !! 0 - pure $ APClosure itbl + AP -> case pts of + [] -> fail "Expected at least 1 ptr argument to AP" + hd : tl -> case payloadWords of + -- We expect at least the arity, n_args, and fun fields + splitWord : _ : _ -> + pure $ APClosure itbl #if defined(WORDS_BIGENDIAN) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) - (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) #else - (fromIntegral splitWord) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (head pts) (tail pts) + hd tl + _ -> fail "Expected at least 2 raw words to AP" - PAP -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to PAP" - -- We expect at least the arity, n_args, and fun fields - unless (length payloadWords >= 2) $ - fail "Expected at least 2 raw words to PAP" - let splitWord = payloadWords !! 0 - pure $ PAPClosure itbl + PAP -> case pts of + [] -> fail "Expected at least 1 ptr argument to PAP" + hd : tl -> case payloadWords of + -- We expect at least the arity, n_args, and fun fields + splitWord : _ : _ -> + pure $ PAPClosure itbl #if defined(WORDS_BIGENDIAN) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) - (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) #else - (fromIntegral splitWord) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (head pts) (tail pts) + hd tl + _ -> fail "Expected at least 2 raw words to PAP" - AP_STACK -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to AP_STACK" - pure $ APStackClosure itbl (head pts) (tail pts) + AP_STACK -> case pts of + [] -> fail "Expected at least 1 ptr argument to AP_STACK" + hd : tl -> pure $ APStackClosure itbl hd tl - IND -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to IND" - pure $ IndClosure itbl (head pts) + IND -> case pts of + [] -> fail "Expected at least 1 ptr argument to IND" + hd : _ -> pure $ IndClosure itbl hd - IND_STATIC -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to IND_STATIC" - pure $ IndClosure itbl (head pts) + IND_STATIC -> case pts of + [] -> fail "Expected at least 1 ptr argument to IND_STATIC" + hd : _ -> pure $ IndClosure itbl hd - BLACKHOLE -> do - unless (length pts >= 1) $ - fail "Expected at least 1 ptr argument to BLACKHOLE" - pure $ BlackholeClosure itbl (head pts) + BLACKHOLE -> case pts of + [] -> fail "Expected at least 1 ptr argument to BLACKHOLE" + hd : _ -> pure $ BlackholeClosure itbl hd - BCO -> do - unless (length pts >= 3) $ - fail $ "Expected at least 3 ptr argument to BCO, found " - ++ show (length pts) - unless (length payloadWords >= 4) $ - fail $ "Expected at least 4 words to BCO, found " - ++ show (length payloadWords) - let splitWord = payloadWords !! 3 - pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) + BCO -> case pts of + pts0 : pts1 : pts2 : _ -> case payloadWords of + _ : _ : _ : splitWord : payloadRest -> + pure $ BCOClosure itbl pts0 pts1 pts2 #if defined(WORDS_BIGENDIAN) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) - (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) #else - (fromIntegral splitWord) - (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) + (fromIntegral splitWord) + (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2)) #endif - (drop 4 payloadWords) + payloadRest + _ -> fail $ "Expected at least 4 words to BCO, found " + ++ show (length payloadWords) + _ -> fail $ "Expected at least 3 ptr argument to BCO, found " + ++ show (length pts) - ARR_WORDS -> do - unless (length payloadWords >= 1) $ - fail $ "Expected at least 1 words to ARR_WORDS, found " + ARR_WORDS -> case payloadWords of + [] -> fail $ "Expected at least 1 words to ARR_WORDS, found " ++ show (length payloadWords) - pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords) + hd : tl -> pure $ ArrWordsClosure itbl hd tl - t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do - unless (length payloadWords >= 2) $ - fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " + t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of + p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts + _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* " ++ "found " ++ show (length payloadWords) - pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts - t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do - unless (length payloadWords >= 1) $ - fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " + t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of + [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* " ++ "found " ++ show (length payloadWords) - pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts + hd : _ -> pure $ SmallMutArrClosure itbl hd pts - t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do - unless (length pts >= 1) $ - fail $ "Expected at least 1 words to MUT_VAR, found " + t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of + [] -> fail $ "Expected at least 1 words to MUT_VAR, found " ++ show (length pts) - pure $ MutVarClosure itbl (head pts) + hd : _ -> pure $ MutVarClosure itbl hd - t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do - unless (length pts >= 3) $ - fail $ "Expected at least 3 ptrs to MVAR, found " + t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of + pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2 + _ -> fail $ "Expected at least 3 ptrs to MVAR, found " ++ show (length pts) - pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2) BLOCKING_QUEUE -> pure $ OtherClosure itbl pts rawHeapWords - -- pure $ BlockingQueueClosure itbl - -- (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3) - -- pure $ OtherClosure itbl pts rawHeapWords - -- - WEAK -> do - pure $ WeakClosure + WEAK -> case pts of + pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure { info = itbl - , cfinalizers = pts !! 0 - , key = pts !! 1 - , value = pts !! 2 - , finalizer = pts !! 3 - , weakLink = case drop 4 pts of + , cfinalizers = pts0 + , key = pts1 + , value = pts2 + , finalizer = pts3 + , weakLink = case rest of [] -> Nothing [p] -> Just p - _ -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts) + _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts) } - TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts + _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts) + TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts -> withArray rawHeapWords (\ptr -> do fields <- FFIClosures.peekTSOFields decodeCCS ptr pure $ TSOClosure @@ -360,6 +344,10 @@ , trec = u_trec , blocked_exceptions = u_blk_ex , bq = u_bq + , thread_label = case other of + [tl] -> Just tl + [] -> Nothing + _ -> error $ "thead_label:Expected 0 or 1 extra arguments" , what_next = FFIClosures.tso_what_next fields , why_blocked = FFIClosures.tso_why_blocked fields , flags = FFIClosures.tso_flags fields @@ -371,7 +359,7 @@ , prof = FFIClosures.tso_prof fields }) | otherwise - -> fail $ "Expected 6 ptr arguments to TSO, found " + -> fail $ "Expected at least 6 ptr arguments to TSO, found " ++ show (length pts) STACK | [] <- pts diff --git a/GHC/Exts/Heap/ClosureTypes.hs b/GHC/Exts/Heap/ClosureTypes.hs --- a/GHC/Exts/Heap/ClosureTypes.hs +++ b/GHC/Exts/Heap/ClosureTypes.hs @@ -80,6 +80,7 @@ | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA + | CONTINUATION | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic) diff --git a/GHC/Exts/Heap/Closures.hs b/GHC/Exts/Heap/Closures.hs --- a/GHC/Exts/Heap/Closures.hs +++ b/GHC/Exts/Heap/Closures.hs @@ -280,6 +280,7 @@ , trec :: !b , blocked_exceptions :: !b , bq :: !b + , thread_label :: !(Maybe b) -- values , what_next :: !WhatNext , why_blocked :: !WhyBlocked diff --git a/GHC/Exts/Heap/Utils.hsc b/GHC/Exts/Heap/Utils.hsc --- a/GHC/Exts/Heap/Utils.hsc +++ b/GHC/Exts/Heap/Utils.hsc @@ -110,11 +110,7 @@ (m, occ) = (intercalate "." $ reverse modWords, occWord) where - (modWords, occWord) = - if length rest1 < 1 -- XXXXXXXXx YUKX - --then error "getConDescAddress:parse:length rest1 < 1" - then parseModOcc [] [] - else parseModOcc [] (tail rest1) + (modWords, occWord) = parseModOcc [] (drop 1 rest1) -- We only look for dots if str could start with a module name, -- i.e. if it starts with an upper case character. -- Otherwise we might think that "X.:->" is the module name in diff --git a/ghc-heap.cabal b/ghc-heap.cabal --- a/ghc-heap.cabal +++ b/ghc-heap.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-heap -version: 9.4.1 +version: 9.6.1 license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org @@ -23,12 +23,13 @@ default-language: Haskell2010 build-depends: base >= 4.9.0 && < 5.0 - , ghc-prim > 0.2 && < 0.10 + , ghc-prim > 0.2 && < 0.11 , rts == 1.0.* , containers >= 0.6.2.1 && < 0.7 ghc-options: -Wall - cmm-sources: cbits/HeapPrim.cmm + if !os(ghcjs) + cmm-sources: cbits/HeapPrim.cmm default-extensions: NoImplicitPrelude