Rodrigo Mesquita pushed to branch wip/romes/27131 at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • testsuite/tests/rts/T27131.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# LANGUAGE UnliftedFFITypes #-}
    3 
    +
    4 
    +module Main where
    5 
    +
    6 
    +import Control.Concurrent
    7 
    +import Control.Monad
    8 
    +import Foreign.C.Types
    9 
    +import GHC.Conc.Sync (ThreadId(..), forkOn, myThreadId, setNumCapabilities)
    10 
    +import GHC.Exts (ThreadId#)
    11 
    +
    12 
    +foreign import ccall unsafe "rts_enableStopNextBreakpoint"
    13 
    +  rts_enableStopNextBreakpoint :: ThreadId# -> IO ()
    14 
    +
    15 
    +foreign import ccall unsafe "rts_disableStopNextBreakpoint"
    16 
    +  rts_disableStopNextBreakpoint :: ThreadId# -> IO ()
    17 
    +
    18 
    +foreign import ccall unsafe "rts_enableStopAfterReturn"
    19 
    +  rts_enableStopAfterReturn :: ThreadId# -> IO ()
    20 
    +
    21 
    +foreign import ccall unsafe "rts_disableStopAfterReturn"
    22 
    +  rts_disableStopAfterReturn :: ThreadId# -> IO ()
    23 
    +
    24 
    +foreign import ccall unsafe "has_local_stop_next_breakpoint"
    25 
    +  c_hasLocalStopNextBreakpoint :: IO CInt
    26 
    +
    27 
    +foreign import ccall unsafe "has_local_stop_after_return"
    28 
    +  c_hasLocalStopAfterReturn :: IO CInt
    29 
    +
    30 
    +main :: IO ()
    31 
    +main = do
    32 
    +  setNumCapabilities 2
    33 
    +  checkFlag
    34 
    +    "TSO_STOP_NEXT_BREAKPOINT"
    35 
    +    rts_enableStopNextBreakpoint
    36 
    +    rts_disableStopNextBreakpoint
    37 
    +    c_hasLocalStopNextBreakpoint
    38 
    +  checkFlag
    39 
    +    "TSO_STOP_AFTER_RETURN"
    40 
    +    rts_enableStopAfterReturn
    41 
    +    rts_disableStopAfterReturn
    42 
    +    c_hasLocalStopAfterReturn
    43 
    +
    44 
    +checkFlag
    45 
    +  :: String
    46 
    +  -> (ThreadId# -> IO ())
    47 
    +  -> (ThreadId# -> IO ())
    48 
    +  -> IO CInt
    49 
    +  -> IO ()
    50 
    +checkFlag label enable disable isMyThreadFlagSet = do
    51 
    +  -- Print the main thread's capability (should be 0)
    52 
    +  print =<< threadCapability =<< myThreadId
    53 
    +
    54 
    +  -- Target thread will write its own flag value here
    55 
    +  targetCheckVar <- newEmptyMVar
    56 
    +
    57 
    +  -- Run the new TSO runs on capability 1
    58 
    +  ThreadId tid# <- forkOn 1 $ do
    59 
    +    replicateM_ 2 $ do
    60 
    +      replyVar <- takeMVar targetCheckVar
    61 
    +      isSet <- (/= 0) <$> isMyThreadFlagSet
    62 
    +      putMVar replyVar isSet
    63 
    +
    64 
    +  -- Enable the other TSO's flag
    65 
    +  enable tid#
    66 
    +  -- It will check whether it is set and reply here
    67 
    +  renderCheck label "set" =<< checkTarget targetCheckVar
    68 
    +
    69 
    +  -- Ditto.
    70 
    +  disable tid#
    71 
    +  renderCheck label "unset" . not =<< checkTarget targetCheckVar
    72 
    +
    73 
    +checkTarget :: MVar (MVar Bool) -> IO Bool
    74 
    +checkTarget targetCheckVar = do
    75 
    +  replyVar <- newEmptyMVar
    76 
    +  putMVar targetCheckVar replyVar
    77 
    +  takeMVar replyVar
    78 
    +
    79 
    +renderCheck :: String -> String -> Bool -> IO ()
    80 
    +renderCheck label state ok = putStrLn $
    81 
    +  label ++ " " ++ state ++ ": " ++ if ok then "ok" else "failed"

  • testsuite/tests/rts/T27131.stdout
    1 
    +(0,False)
    2 
    +TSO_STOP_NEXT_BREAKPOINT set: ok
    3 
    +TSO_STOP_NEXT_BREAKPOINT unset: ok
    4 
    +(0,False)
    5 
    +TSO_STOP_AFTER_RETURN set: ok
    6 
    +TSO_STOP_AFTER_RETURN unset: ok

  • testsuite/tests/rts/T27131_c.c
    1 
    +#include "Rts.h"
    2 
    +
    3 
    +int has_local_stop_next_breakpoint(void)
    4 
    +{
    5 
    +    CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability();
    6 
    +    StgTSO *tso = cap->r.rCurrentTSO;
    7 
    +    return (tso->flags & TSO_STOP_NEXT_BREAKPOINT) != 0;
    8 
    +}
    9 
    +
    10 
    +int has_local_stop_after_return(void)
    11 
    +{
    12 
    +    CapabilityPublic *cap = (CapabilityPublic *) rts_unsafeGetMyCapability();
    13 
    +    StgTSO *tso = cap->r.rCurrentTSO;
    14 
    +    return (tso->flags & TSO_STOP_AFTER_RETURN) != 0;
    15 
    +}

  • testsuite/tests/rts/all.T
    ... ... @@ -623,6 +623,13 @@ test('T20201b', [js_skip, exit_code(1)], compile_and_run, ['-with-rtsopts -A64z'
    623 623
    624 624 
     test('T22012', [js_skip, extra_ways(['ghci'])], compile_and_run, ['T22012_c.c'])
    625 625
    626 
    +test('T27131',
    627 
    +     [ only_ways(['threaded1', 'threaded2'])
    628 
    +     , req_ghc_with_threaded_rts
    629 
    +     , req_target_smp
    630 
    +     ],
    631 
    +     compile_and_run, ['T27131_c.c'])
    632 
    +
    626 633 
     # Skip for JS platform as the JS RTS is always single threaded
    627 634 
     test('T22795a', [only_ways(['normal']), js_skip, req_ghc_with_threaded_rts], compile_and_run, ['-threaded'])
    628 635 
     test('T22795b', [only_ways(['normal']), js_skip], compile_and_run, ['-single-threaded'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help