Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • compiler/GHC/Types/Demand.hs
    1 1
    2 2 
     {-# LANGUAGE ViewPatterns #-}
    3 
    +{-# LANGUAGE LambdaCase #-}
    3 4 
     {-# LANGUAGE BinaryLiterals #-}
    4 5 
     {-# LANGUAGE PatternSynonyms #-}
    5 6
    ... ... @@ -2844,7 +2845,10 @@ instance Outputable DmdEnv where
    2844 2845 
         = ppr div <> if null fv_elts then empty
    2845 2846 
                      else braces (fsep (map pp_elt fv_elts))
    2846 2847 
         where
    2847 
    -      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
    2848 
    +      pp_elt (uniq, dmd) =
    2849 
    +        sdocOption sdocSuppressUniques $ \case
    2850 
    +          True  -> ppr dmd
    2851 
    +          False -> ppr uniq <> text "->" <> ppr dmd
    2848 2852 
           fv_elts = nonDetUFMToList fvs
    2849 2853 
             -- It's OK to use nonDetUFMToList here because we only do it for
    2850 2854 
             -- pretty printing

  • rts/CloneStack.c
    ... ... @@ -89,15 +89,31 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
    89 89 
       sendMessage(srcCapability, tso->cap, (Message *)msg);
    90 90 
     }
    91 91
    92 
    -void handleCloneStackMessage(MessageCloneStack *msg){
    93 
    -  StgStack* newStackClosure = cloneStack(msg->tso->cap, msg->tso->stackobj);
    92 
    +// The cap argument is the capability which is handling the CloneStack message
    93 
    +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){
    94 
    +  // We must check that the current owner of the thread we want to clone the stack for
    95 
    +  // is still this capability.
    96 
    +  Capability *owner = RELAXED_LOAD(&msg->tso->cap);
    97 
    +  if (owner != cap) {
    98 
    +    // The target TSO may have migrated after the message was queued on the old
    99 
    +    // capability. In that case we must forward the request to the current
    100 
    +    // owner; otherwise we would race with another capability mutating the
    101 
    +    // stack while we clone it.
    102 
    +    sendMessage(cap, owner, (Message *)msg);
    103 
    +    return;
    104 
    +  }
    105 
    +
    106 
    +  // At this point the executing capability owns the TSO, so it is the only
    107 
    +  // capability that may safely inspect the live stack and the one whose
    108 
    +  // allocator we must use for the cloned StgStack closure.
    109 
    +  StgStack* newStackClosure = cloneStack(cap, msg->tso->stackobj);
    94 110
    95 111 
       // Lift StackSnapshot# to StackSnapshot by applying it's constructor.
    96 112 
       // This is necessary because performTryPutMVar() puts the closure onto the
    97 113 
       // stack for evaluation and stacks can not be evaluated (entered).
    98 
    -  HaskellObj result = rts_apply(msg->tso->cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure);
    114 
    +  HaskellObj result = rts_apply(cap, StackSnapshot_constructor_closure, (HaskellObj) newStackClosure);
    99 115
    100 
    -  bool putMVarWasSuccessful = performTryPutMVar(msg->tso->cap, msg->result, result);
    116 
    +  bool putMVarWasSuccessful = performTryPutMVar(cap, msg->result, result);
    101 117
    102 118 
       if(!putMVarWasSuccessful) {
    103 119 
         barf("Can't put stack cloning result into MVar.");

  • rts/CloneStack.h
    ... ... @@ -19,7 +19,7 @@ StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack);
    19 19 
     #include "BeginPrivate.h"
    20 20
    21 21 
     #if defined(THREADED_RTS)
    22 
    -void handleCloneStackMessage(MessageCloneStack *msg);
    22 
    +void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg);
    23 23 
     #endif
    24 24
    25 25 
     #include "EndPrivate.h"

  • rts/Interpreter.c
    ... ... @@ -179,6 +179,24 @@ tag functions as tag inference currently doesn't rely on those being properly ta
    179 179 
     #define WITHIN_CHUNK_BOUNDS_W(n, s)  \
    180 180 
         (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
    181 181
    182 
    +/* Note [Checking for underflow frames]
    183 
    +   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    184 
    +
    185 
    +   We look at the stack slot at offset sizeof(StgUnderflowFrame) from
    186 
    +   the start of the chunk to check if we're in the first check chunk.
    187 
    +   Every non-first stack chunk has an underflow frame header at that offset.
    188 
    +
    189 
    +   We really should change this check, since this stack slot in the first
    190 
    +   chunk may not be the start of a stack frame and could in theory contain
    191 
    +   an arbitrary value.
    192 
    +
    193 
    +   In practice we're unlikely to have interpreted frames that low on the stack.
    194 
    + */
    195 
    +#define IS_UNDERFLOW_FRAME(info) \
    196 
    +    ((info) == &stg_stack_underflow_frame_d_info ||   \
    197 
    +     (info) == &stg_stack_underflow_frame_v16_info || \
    198 
    +     (info) == &stg_stack_underflow_frame_v32_info || \
    199 
    +     (info) == &stg_stack_underflow_frame_v64_info)
    182 200
    183 201 
     #define W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord)))
    184 202
    ... ... @@ -431,11 +449,9 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
    431 449 
         frame = (StgUnderflowFrame*)(cur_stack->stack + cur_stack->stack_size
    432 450 
                    - sizeofW(StgUnderflowFrame));
    433 451
    434 
    -    // 2a. Check it is an underflow frame (the top stack chunk won't have one).
    435 
    -    if( frame->info == &stg_stack_underflow_frame_d_info
    436 
    -       || frame->info == &stg_stack_underflow_frame_v16_info
    437 
    -       || frame->info == &stg_stack_underflow_frame_v32_info
    438 
    -       || frame->info == &stg_stack_underflow_frame_v64_info )
    452 
    +    // 2a. Check it is an underflow frame (the first stack chunk won't have one).
    453 
    +    //     See Note [Checking for underflow frames]
    454 
    +    if( IS_UNDERFLOW_FRAME(frame->info) )
    439 455 
         {
    440 456
    441 457 
           INTERP_TICK(it_underflow_lookups);
    ... ... @@ -452,9 +468,11 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
    452 468 
         }
    453 469 
         // 2b. Access the element if there is no underflow frame, it must be right
    454 470 
         // at the top of the stack.
    455 
    -    else {
    456 
    -        // Not actually in the underflow case
    471 
    +    else if(Sp_plusW(offset_words) < (StgPtr)(cur_stack->stack + cur_stack->stack_size)) {
    472 
    +        // Still inside the stack chunk
    457 473 
             return Sp_plusW(offset_words);
    474 
    +    } else {
    475 
    +        barf("slow_spw: offset_words %d is out of bounds", (int)offset_words);
    458 476 
         }
    459 477 
       }
    460 478 
     }
    ... ... @@ -1788,8 +1806,39 @@ run_BCO:
    1788 1806 
                  *           =>
    1789 1807 
                  * a_1 ... a_n, k
    1790 1808 
                  */
    1791 
    -            while(n-- > 0) {
    1792 
    -                SpW(n+by) = ReadSpW(n);
    1809 
    +            if (n == 0 || WITHIN_CAP_CHUNK_BOUNDS_W(n - 1 + by)) {
    1810 
    +                while(n-- > 0) {
    1811 
    +                    SpW(n+by) = ReadSpW(n);
    1812 
    +                }
    1813 
    +            } else {
    1814 
    +                // We write across a chunk boundary: Use safe access
    1815 
    +                while(n-- > 0) {
    1816 
    +                    *((StgWord*)SafeSpWP(n+by)) = ReadSpW(n);
    1817 
    +                }
    1818 
    +            }
    1819 
    +
    1820 
    +            // If we SLIDE Sp past the chunk bounds we need to handle the underflow
    1821 
    +            // (possibly multiple times)
    1822 
    +            while (!WITHIN_CAP_CHUNK_BOUNDS_W(by)) {
    1823 
    +                StgStack *stk = cap->r.rCurrentTSO->stackobj;
    1824 
    +                StgUnderflowFrame *uf = (StgUnderflowFrame*)
    1825 
    +                    (stk->stack + stk->stack_size
    1826 
    +                     - sizeofW(StgUnderflowFrame));
    1827 
    +                // See Note [Checking for underflow frames]
    1828 
    +                if (IS_UNDERFLOW_FRAME(uf->info)) {
    1829 
    +                    W_ sp_to_uf = (StgWord*)uf - (StgWord*)Sp;
    1830 
    +                    Sp = (StgPtr)uf;
    1831 
    +                    SAVE_STACK_POINTERS;
    1832 
    +                    threadStackUnderflow(cap, cap->r.rCurrentTSO);
    1833 
    +                    LOAD_STACK_POINTERS;
    1834 
    +                    by -= sp_to_uf;
    1835 
    +                } else if (Sp_plusW(by) < (StgPtr)(stk->stack + stk->stack_size)) {
    1836 
    +                    // we're within the first stack chunk, this chunk has
    1837 
    +                    // no underflow frame
    1838 
    +                    break;
    1839 
    +                } else {
    1840 
    +                    barf("bci_SLIDE: Sp+by outside stack bounds");
    1841 
    +                }
    1793 1842 
                 }
    1794 1843 
                 Sp_addW(by);
    1795 1844 
                 INTERP_TICK(it_slides);

  • rts/Messages.c
    ... ... @@ -135,7 +135,7 @@ loop:
    135 135 
         }
    136 136 
         else if(i == &stg_MSG_CLONE_STACK_info){
    137 137 
             MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m;
    138 
    -        handleCloneStackMessage(cloneStackMessage);
    138 
    +        handleCloneStackMessage(cap, cloneStackMessage);
    139 139 
         }
    140 140 
         else
    141 141 
         {

  • rts/StgMiscClosures.cmm
    ... ... @@ -47,6 +47,7 @@ import CLOSURE stg_ret_v_info;
    47 47 
     /* See Note [Original thunk info table frames] in GHC.StgToCmm.Bind. */
    48 48 
     INFO_TABLE_RET (stg_orig_thunk_info_frame, RET_SMALL,
    49 49 
                     W_ info_ptr,
    50 
    +                PROF_HDR_FIELDS(W_, p1, p2)
    50 51 
                     W_ thunk_info_ptr)
    51 52 
         /* no args => explicit stack */
    52 53 
     {

  • testsuite/tests/bytecode/T27001.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +-- Test that SLIDE works correctly when it crosses a stack chunk boundary.
    3 
    +-- See #27001.
    4 
    +module Main where
    5 
    +
    6 
    +go :: Int -> Double -> Double
    7 
    +go 0 !acc = acc
    8 
    +go n !acc = go (n - 1) (acc + 1.0)
    9 
    +
    10 
    +result :: Double
    11 
    +result = go 100000 0.0
    12 
    +
    13 
    +main :: IO ()
    14 
    +main = print result

  • testsuite/tests/bytecode/T27001.stdout
    1 
    +(0.15 secs,)
    2 
    +it :: ()
    3 
    +100000.0
    4 
    +(0.09 secs, 51,566,104 bytes)

  • testsuite/tests/bytecode/all.T
    ... ... @@ -9,3 +9,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run,
    9 9 
     # Nullary data constructors
    10 10 
     test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script'])
    11 11
    12 
    +
    13 
    +# SLIDE across stack chunk boundary (#27001)
    14 
    +test('T27001', [extra_files(['T27001.hs']), req_interp],
    15 
    +     run_command,
    16 
    +     ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs'])

  • testsuite/tests/dmdanal/should_compile/T13143.stderr
    ... ... @@ -6,8 +6,8 @@ Result size of Tidy Core
    6 6 
     Rec {
    7 7 
     -- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
    8 8 
     T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker]
    9 
    -  :: forall {a}. (# #) -> a
    10 
    -[GblId, Arity=1, Str=<B>b{sBo->S}, Cpr=b, Unf=OtherCon []]
    9 
    +  :: forall a. (# #) -> a
    10 
    +[GblId, Arity=1, Str=<B>b{S}, Cpr=b, Unf=OtherCon []]
    11 11 
     T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Types.(##)
    12 12 
     end Rec }
    13 13
    ... ... @@ -15,7 +15,7 @@ end Rec }
    15 15 
     f [InlPrag=NOINLINE[final]] :: forall a. Int -> a
    16 16 
     [GblId,
    17 17 
      Arity=1,
    18 
    - Str=<B>b{sBo->S},
    18 
    + Str=<B>b{S},
    19 19 
      Cpr=b,
    20 20 
      Unf=Unf{Src=StableSystem, TopLvl=True,
    21 21 
              Value=True, ConLike=True, WorkFree=True, Expandable=True,
    ... ... @@ -66,7 +66,7 @@ T13143.$trModule
    66 66
    67 67 
     -- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
    68 68 
     lvl :: Int
    69 
    -[GblId, Str=b{sBo->S}, Cpr=b]
    69 
    +[GblId, Str=b{S}, Cpr=b]
    70 70 
     lvl = T13143.$wf @Int GHC.Types.(##)
    71 71
    72 72 
     Rec {

  • testsuite/tests/dmdanal/should_compile/T27106.hs
    1 
    +module T27106 where
    2 
    +
    3 
    +{-# NOINLINE weird #-}
    4 
    +weird :: Int -> a
    5 
    +weird x = weird x

  • testsuite/tests/dmdanal/should_compile/T27106.stderr
    1 
    +weird [InlPrag=NOINLINE[final]] :: forall a. Int -> a
    2 
    +[GblId,
    3 
    + Arity=1,
    4 
    + Str=<B>b{S},

  • testsuite/tests/dmdanal/should_compile/all.T
    ... ... @@ -45,6 +45,13 @@ test('T13077a', normal, compile, [''])
    45 45 
     # T13143: WW for NOINLINE function f
    46 46 
     test('T13143', [ grep_errmsg(r'^T13143\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques'])
    47 47
    48 
    +# Uniques in the free variable part of a demand signature should be
    49 
    +# suppressed by -dsuppress-uniques.
    50 
    +test('T27106', normal, multimod_compile_filter,
    51 
    +     ['T27106',
    52 
    +      '-v0 -O -ddump-simpl -dsuppress-uniques',
    53 
    +      r"sed -n '/^weird /,/.* Str=/p'"])
    54 
    +
    48 55 
     # T15627
    49 56 
     #   Absent bindings of unlifted types should be WW'ed away.
    50 57 
     #   The idea is to check that both $wmutVar and $warray

  • testsuite/tests/rts/all.T
    ... ... @@ -583,6 +583,15 @@ test('cloneMyStack_retBigStackFrame', [req_c, extra_files(['cloneStackLib.c']),
    583 583
    584 584 
     test('cloneThreadStack', [req_c, only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c']), req_ghc_with_threaded_rts], compile_and_run, ['cloneStackLib.c -threaded'])
    585 585
    586 
    +test('cloneThreadStackMigrating',
    587 
    +  [ ignore_stdout
    588 
    +  , only_ways(['threaded1'])
    589 
    +  , extra_ways(['threaded1'])
    590 
    +  , extra_run_opts('+RTS -N -DS -RTS')
    591 
    +  , req_ghc_with_threaded_rts
    592 
    +  , req_target_smp
    593 
    +  ], compile_and_run, ['-threaded -debug -rtsopts'])
    594 
    +
    586 595 
     test('decodeMyStack',
    587 596 
       [ omit_ghci, js_broken(22261) # cloneMyStack# not yet implemented
    588 597 
       ], compile_and_run, ['-finfo-table-map'])

  • testsuite/tests/rts/cloneThreadStackMigrating.hs
    1 
    +module Main where
    2 
    +
    3 
    +import Control.Concurrent
    4 
    +import Control.Monad
    5 
    +import GHC.Exts.Stack
    6 
    +import GHC.Stack.CloneStack
    7 
    +
    8 
    +numWorkers :: Int
    9 
    +numWorkers = 100
    10 
    +
    11 
    +startN :: Int
    12 
    +startN = 10
    13 
    +
    14 
    +runForMicros :: Int
    15 
    +runForMicros = 1000000
    16 
    +
    17 
    +fib :: Int -> Int
    18 
    +fib 0 = 1
    19 
    +fib 1 = 1
    20 
    +fib n = fib (n - 1) + fib (n - 2)
    21 
    +
    22 
    +workerThread :: Int -> IO ()
    23 
    +workerThread n = do
    24 
    +  fib n `seq` pure ()
    25 
    +  workerThread (n + 1)
    26 
    +
    27 
    +cloneThread :: ThreadId -> IO ()
    28 
    +cloneThread tid = forever $ do
    29 
    +  snapshot <- cloneThreadStack tid
    30 
    +  stack <- decodeStack snapshot
    31 
    +  stack `seq` pure ()
    32 
    +
    33 
    +main :: IO ()
    34 
    +main = do
    35 
    +  tids <- replicateM numWorkers (forkIO $ workerThread startN)
    36 
    +  mapM_ (forkIO . cloneThread) tids
    37 
    +  threadDelay runForMicros

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