[GHC] #13331: Worker/wrapper can lead to sharing failure

[GHC]

#13331: Worker/wrapper can lead to sharing failure
-------------------------------------+-------------------------------------
        Reporter:  dfeuer            |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:  8.4.1
       Component:  Compiler          |              Version:  8.1
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
 Type of failure:  Runtime           |  Unknown/Multiple
  performance bug                    |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------
Description changed by dfeuer:

Old description:

> `nofib` turned up a serious performance bug in the implementation of
> `insert` in `containers-0.5.10.1`. The function was defined thus:
>
> {{{#!hs
> origInsert :: Ord k => k -> a -> Map k a -> Map k a
> origInsert = go
>   where
>     go :: Ord k => k -> a -> Map k a -> Map k a
>     go !kx x Tip = singleton kx x
>     go !kx x t@(Bin sz ky y l r) =
>         case compare kx ky of
>             LT | l' `ptrEq` l -> t
>                | otherwise -> balanceL ky y l' r
>                where !l' = go kx x l
>             GT | r' `ptrEq` r -> t
>                | otherwise -> balanceR ky y l r'
>                where !r' = go kx x r
>             EQ | kx `ptrEq` ky && x `ptrEq` y -> t
>                | otherwise -> Bin sz kx x l r
>
> {-# INLINABLE origInsert #-}
> }}}
>
> When this specializes to `Int` keys (or any other "unboxable" ones,
> including tuples), worker/wrapper botches the job:
>
> {{{
> Rec {
> -- RHS size: {terms: 102, types: 65, coercions: 0}
> $w$sgo
>   :: forall a_a7M6.
>      Int# -> a_a7M6 -> Map Int a_a7M6 -> Map Int a_a7M6
> $w$sgo =
>   \ (@ a_a7M6)
>     (ww_s8oI :: Int#)
>     (w_s8oE :: a_a7M6)
>     (w1_s8oF :: Map Int a_a7M6) ->
>     let {
>       kx_X7KQ :: Int
>       kx_X7KQ = I# ww_s8oI } in
>     case w1_s8oF of wild_Xg {
>
> [...]
>
> origInsertInt_$sgo
>   :: forall a_a7M6. Int -> a_a7M6 -> Map Int a_a7M6 -> Map Int a_a7M6
> origInsertInt_$sgo =
>   \ (@ a_a7M6)
>     (w_s8oD :: Int)
>     (w1_s8oE :: a_a7M6)
>     (w2_s8oF :: Map Int a_a7M6) ->
>     case w_s8oD of _ { I# ww1_s8oI -> $w$sgo ww1_s8oI w1_s8oE w2_s8oF }
> }}}
>
> The wrapper opens the box, throws it away, and passes the contents to the
> worker, which immediately builds a ''new'' box with exactly the same
> contents. This prevents the pointer equality tests from succeeding for
> these types, and it also turns out to cause quite a lot of extra
> allocation for some types (leading to the severe nofib regression).
>
> One could reasonably argue that the code above is a bit complicated, and
> that GHC could be forgiven for failing to realize that the box should be
> saved. Unfortunately, a straightforward change that would seem to make
> this clear does not in fact convince GHC:
>
> {{{#!hs
> myInsert :: Ord k => k -> a -> Map k a -> Map k a
> myInsert kx0 = go kx0
>   where
>     go !kx x Tip = singleton kx0 x
>     go !kx x t@(Bin sz ky y l r) =
>         case compare kx ky of
>             LT | l' `ptrEq` l -> t
>                | otherwise -> balanceL ky y l' r
>                where !l' = go kx x l
>             GT | r' `ptrEq` r -> t
>                | otherwise -> balanceR ky y l r'
>                where !r' = go kx x r
>             EQ | kx0 `ptrEq` ky && x `ptrEq` y -> t
>                | otherwise -> Bin sz kx0 x l r
>
> {-# INLINABLE myInsert #-}
> }}}
>
> does exactly the same thing. The only ''simple'' way I found to avoid
> that is to remove the bang patterns, which really ''shouldn't'' work, but
> does. This, however, is prohibited by the required semantics—we
> must be strict in the key even if comparison is not. The only fix I've
> found thus far is truly disgusting, and seems to work at least partly by
> mistake:
>
> {{{#!hs
> insert :: Ord k => k -> a -> Map k a -> Map k a
> insert kx0 = go kx0 kx0
>   where
>     go :: Ord k => k -> k -> a -> Map k a -> Map k a
>     go orig !kx x Tip = singleton (lazy orig) x
>     go orig !kx x t@(Bin sz ky y l r) =
>         case compare kx ky of
>             LT | l' `ptrEq` l -> t
>                | otherwise -> balanceL ky y l' r
>                where !l' = go orig kx x l
>             GT | r' `ptrEq` r -> t
>                | otherwise -> balanceR ky y l r'
>                where !r' = go orig kx x r
>             EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t
>                | otherwise -> Bin sz (lazy orig) x l r
>
> {-# INLINABLE insert #-}
> }}}
>
> We would also like to be able to experiment with an implementation that
> uses CPS (recursive join points today!) rather than pointer equality
> tests for the internal nodes, leaving pointer equality to the leaves. But
> I have not found any way whatsoever to avoid this W/W problem in that
> version.

New description:

 `nofib` turned up a serious performance bug in the implementation of
 `insert` in `containers-0.5.10.1`. The function was defined thus:

 {{{#!hs
 origInsert :: Ord k => k -> a -> Map k a -> Map k a
 origInsert = go
   where
     go :: Ord k => k -> a -> Map k a -> Map k a
     go !kx x Tip = singleton kx x
     go !kx x t@(Bin sz ky y l r) =
         case compare kx ky of
             LT | l' `ptrEq` l -> t
                | otherwise -> balanceL ky y l' r
                where !l' = go kx x l
             GT | r' `ptrEq` r -> t
                | otherwise -> balanceR ky y l r'
                where !r' = go kx x r
             EQ | kx `ptrEq` ky && x `ptrEq` y -> t
                | otherwise -> Bin sz kx x l r

 {-# INLINABLE origInsert #-}
 }}}

 When this specializes to `Int` keys (or any other "unboxable" ones,
 including tuples), worker/wrapper botches the job:

 {{{
 Rec {
 -- RHS size: {terms: 102, types: 65, coercions: 0}
 $w$sgo
   :: forall a_a7M6.
      Int# -> a_a7M6 -> Map Int a_a7M6 -> Map Int a_a7M6
 $w$sgo =
   \ (@ a_a7M6)
     (ww_s8oI :: Int#)
     (w_s8oE :: a_a7M6)
     (w1_s8oF :: Map Int a_a7M6) ->
     let {
       kx_X7KQ :: Int
       kx_X7KQ = I# ww_s8oI } in
     case w1_s8oF of wild_Xg {

 [...]

 origInsertInt_$sgo
   :: forall a_a7M6. Int -> a_a7M6 -> Map Int a_a7M6 -> Map Int a_a7M6
 origInsertInt_$sgo =
   \ (@ a_a7M6)
     (w_s8oD :: Int)
     (w1_s8oE :: a_a7M6)
     (w2_s8oF :: Map Int a_a7M6) ->
     case w_s8oD of _ { I# ww1_s8oI -> $w$sgo ww1_s8oI w1_s8oE w2_s8oF }
 }}}

 The wrapper opens the box, throws it away, and passes the contents to the
 worker, which immediately builds a ''new'' box with exactly the same
 contents. This prevents the pointer equality tests from succeeding for
 these types, and it also turns out to cause quite a lot of extra
 allocation for some types (leading to the severe nofib regression).

 One could reasonably argue that the code above is a bit complicated, and
 that GHC could be forgiven for failing to realize that the box should be
 saved. Unfortunately, a straightforward change that would seem to make
 this clear does not in fact convince GHC:

 {{{#!hs
 myInsert :: Ord k => k -> a -> Map k a -> Map k a
 myInsert kx0 = go kx0
   where
     go !kx x Tip = singleton kx0 x
     go !kx x t@(Bin sz ky y l r) =
         case compare kx ky of
             LT | l' `ptrEq` l -> t
                | otherwise -> balanceL ky y l' r
                where !l' = go kx x l
             GT | r' `ptrEq` r -> t
                | otherwise -> balanceR ky y l r'
                where !r' = go kx x r
             EQ | kx0 `ptrEq` ky && x `ptrEq` y -> t
                | otherwise -> Bin sz kx0 x l r

 {-# INLINABLE myInsert #-}
 }}}

 does exactly the same thing. The only ''simple'' way I found to avoid that
 is to remove the bang patterns, which really ''shouldn't'' work, but does.
 This, however, is prohibited by the desired semantics—I believe we want to
 be strict in the key even if comparison is not. In any case, that really
 shouldn't be causing trouble and it is. The only fix I've found thus far
 is truly disgusting, and seems to work at least partly by mistake:

 {{{#!hs
 insert :: Ord k => k -> a -> Map k a -> Map k a
 insert kx0 = go kx0 kx0
   where
     go :: Ord k => k -> k -> a -> Map k a -> Map k a
     go orig !kx x Tip = singleton (lazy orig) x
     go orig !kx x t@(Bin sz ky y l r) =
         case compare kx ky of
             LT | l' `ptrEq` l -> t
                | otherwise -> balanceL ky y l' r
                where !l' = go orig kx x l
             GT | r' `ptrEq` r -> t
                | otherwise -> balanceR ky y l r'
                where !r' = go orig kx x r
             EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t
                | otherwise -> Bin sz (lazy orig) x l r

 {-# INLINABLE insert #-}
 }}}

 We would also like to be able to experiment with an implementation that
 uses CPS (recursive join points today!) rather than pointer equality tests
 for the internal nodes, leaving pointer equality to the leaves. But I have
 not found any way whatsoever to avoid this W/W problem in that version.

--

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/13331#comment:1>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler