Opened 6 years ago

Closed 18 months ago

#2440 closed bug (fixed)

Bad code with type families

Reported by: rl Owned by:
Priority: lowest Milestone: 7.6.2
Component: Compiler Version: 6.9
Keywords: Cc:
Operating System: Unknown/Multiple Architecture: Unknown/Multiple
Type of failure: Runtime performance bug Difficulty: Unknown
Test Case: Blocked By:
Blocking: Related Tickets:

Description

{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
module Foo (foo) where

import Control.Monad.ST
import Data.STRef

class V v where
  type M v :: * -> *

  rd :: v -> Int -> M v Int

data Vec s = Vec (STRef s Int)

instance V (Vec s) where
  type M (Vec s) = ST s

  rd (Vec r) n = do
                   m <- readSTRef r
                   return (m+n)

foo :: forall s. Vec s -> Int -> ST s Int
foo v n = go n
  where
    go 0 = return 0
    go n = do
             m <- rd v n -- :: ST s Int
             go m

ghc -O2 generates rather bad code for this (look at $wfoo). If I uncomment the type signature in the second to last line, the code becomes much better. It would be nice if this worked without the signature since I can't add it in the real code.

Attachments (1)

T2440.hs (513 bytes) - added by morabbin 18 months ago.
Exhibits problems described in #2440

Download all attachments as: .zip

Change History (21)

comment:1 Changed 6 years ago by igloo

  • Difficulty set to Unknown
  • Milestone set to 6.10 branch

Thanks for the report

comment:2 Changed 6 years ago by simonmar

  • Architecture changed from Unknown to Unknown/Multiple

comment:3 Changed 6 years ago by simonmar

  • Operating System changed from Unknown to Unknown/Multiple

comment:4 Changed 6 years ago by batterseapower

Interesting. I can't find $wfoo, but I did find this suspicious looking function:

a_smw :: forall s_afW.
         Foo.Vec s_afW
         -> GHC.Types.Int
         -> Foo.M (Foo.Vec s_afW) GHC.Types.Int
[Arity 2
 Str: DmdType U(L)L]
a_smw =
  \ (@ s_afW) (ds_Xmw :: Foo.Vec s_afW) (n_Xgx :: GHC.Types.Int) ->
    case ds_Xmw of _ { Foo.Vec r_afZ [ALWAYS Just D(L)] ->
    (\ (s_ane :: GHC.Prim.State# s_afW) ->
       case r_afZ of _ { GHC.STRef.STRef var#_anJ [ALWAYS Just L] ->
       case GHC.Prim.readMutVar# @ s_afW @ GHC.Types.Int var#_anJ s_ane
       of _ { (# new_s_ank [ALWAYS Just L], r_anl [ALWAYS Just D(L)] #) ->
       (# new_s_ank,
          case r_anl of _ { GHC.Types.I# x_anS [ALWAYS Just L] ->
          case n_Xgx of _ { GHC.Types.I# y_anW [ALWAYS Just L] ->
          GHC.Types.I# (GHC.Prim.+# x_anS y_anW)
          }
          } #)
       }
       })
    `cast` (trans
              (sym (GHC.ST.NTCo:ST s_afW GHC.Types.Int))
              (trans
                 (sym
                    (trans
                       (Foo.TFCo:R1:M s_afW)
                       (sym
                          (trans
                             (trans (GHC.ST.ST s_afW) (GHC.ST.ST s_afW)) (GHC.ST.ST s_afW)))))
                 (Foo.M (Foo.Vec s_afW))
                 GHC.Types.Int)
            :: GHC.ST.STRep s_afW GHC.Types.Int
                 ~
               Foo.M (Foo.Vec s_afW) GHC.Types.Int)
    }

We'd really like to give this an arity of 3, but GHC is currently not smart enough to eta-expand through this type coercion (see the final case of eta_expand in CoreUtils.lhs).

comment:5 Changed 6 years ago by simonpj

Yes, I think that's exactly the problem. The eta-expander needs to be smarter. But, as you pointed out when we met, in general that means making use of the coercion terms in the expression; we can no longer say "this term e of type ty has arity 3; please eta-expand it", because the coercion terms needed to do so may be complicated.

Simon

comment:6 Changed 6 years ago by batterseapower

Is there some reason the coercion for this case is so complicated? It seems to me (with my admittedly limited knowledge of type coercions) that we could improve it to:

(trans (sym (GHC.ST.NTCo:ST s GHC.Types.Int))

((sym (Foo.TFCo:R1:M s)) GHC.Types.Int))

STRep s Int ~ M (Vec s) Int

Here I have used the rewrite rules:

trans (x :: a ~ a) (x :: a ~ a) ==> x
sym (x :: a ~ a) ==> x
trans x (y :: a ~ a) ==> x

And optionally you could also do:

trans (sym x) (sym y) ==> sym (trans x y)

I don't think this helps fixing this bug at all, but it seemed a bit fishy to me, and doing this improvement would at least help readability of Core. Am I way off base here?

comment:7 follow-up: Changed 6 years ago by batterseapower

(Repost for formatting reasons...)

Is there some reason the coercion for this case is so complicated? It seems to me (with my admittedly limited knowledge of type coercions) that we could improve it to:

(trans (sym (GHC.ST.NTCo:ST s GHC.Types.Int))
       ((sym (Foo.TFCo:R1:M s)) GHC.Types.Int))
  :: STRep s Int ~ M (Vec s) Int

Here I have used the rewrite rules:

trans (x :: a ~ a) (x :: a ~ a) ==> x
sym (x :: a ~ a) ==> x
trans x (y :: a ~ a) ==> x

And optionally you could also do:

trans (sym x) (sym y) ==> sym (trans x y)

I don't think this helps fixing this bug at all, but it seemed a bit fishy to me, and doing this improvement would at least help readability of Core. Am I way off base here?

comment:8 in reply to: ↑ 7 Changed 6 years ago by chak

Replying to batterseapower:

(Repost for formatting reasons...)

Is there some reason the coercion for this case is so complicated? It seems to me (with my admittedly limited knowledge of type coercions) that we could improve it to:

You are right that coercions sometimes get overly complicated. That is often due to shortcomings of the representation used when generating these coercions. We would like to fix that, but so far haven't settled on exactly how (and also like to avoid rearranging the source in many places).

comment:9 Changed 6 years ago by simonpj

Right. I've opened a ticket for this: #2859.

Simon

comment:10 Changed 5 years ago by igloo

  • Milestone changed from 6.10 branch to 6.12 branch

comment:11 Changed 5 years ago by simonmar

  • Type of failure set to Runtime performance bug

comment:12 Changed 4 years ago by igloo

  • Milestone changed from 6.12 branch to 6.12.3

comment:13 Changed 4 years ago by igloo

  • Milestone changed from 6.12.3 to 6.14.1
  • Priority changed from normal to low

comment:14 Changed 4 years ago by igloo

  • Milestone changed from 7.0.1 to 7.0.2

comment:15 Changed 3 years ago by igloo

  • Milestone changed from 7.0.2 to 7.2.1

comment:16 Changed 3 years ago by igloo

  • Milestone changed from 7.2.1 to 7.4.1

comment:17 Changed 2 years ago by igloo

  • Milestone changed from 7.4.1 to 7.6.1
  • Priority changed from low to lowest

comment:18 Changed 22 months ago by igloo

  • Milestone changed from 7.6.1 to 7.6.2

Changed 18 months ago by morabbin

Exhibits problems described in #2440

comment:19 Changed 18 months ago by morabbin

Since #2859 is closed as fixed, ought this be also?

comment:20 Changed 18 months ago by simonpj

  • Resolution set to fixed
  • Status changed from new to closed

Well #2859 concerns optimising coercions, which was a sideline on this ticket, and is indeed fixed.

However, I tried compiling T2440 with -O and got this resonably good code. In particular, the worker for foo has arity 3 as desired. So I'll close.

Foo.$wa
  :: forall s_agY.
     Foo.Vec s_agY
     -> GHC.Prim.Int#
     -> GHC.Prim.State# s_agY
     -> (# GHC.Prim.State# s_agY, GHC.Types.Int #)
[GblId,
 Arity=3,
 Caf=NoCafRefs,
 Str=DmdType <L,U(U(U))><S,U><L,U>,
 Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=3, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=IF_ARGS [20 0 0] 142 0}]
Foo.$wa =
  \ (@ s_agY)
    (w_sr0 :: Foo.Vec s_agY)
    (ww_sr3 :: GHC.Prim.Int#)
    (w1_sr5 :: GHC.Prim.State# s_agY) ->
    letrec {
      $wa1_sr8 [Occ=LoopBreaker]
        :: GHC.Prim.Int#
           -> GHC.Prim.State# s_agY
           -> (# GHC.Prim.State# s_agY, GHC.Types.Int #)
      [LclId, Arity=2, Str=DmdType <S,U><L,U>]
      $wa1_sr8 =
        \ (ww1_sqT :: GHC.Prim.Int#) (w2_sqV :: GHC.Prim.State# s_agY) ->
          case ww1_sqT of ds_Xok {
            __DEFAULT ->
              case w_sr0 of _ { Foo.Vec r_afI ->
              case r_afI of _ { GHC.STRef.STRef var#_apW ->
              case GHC.Prim.readMutVar# @ s_agY @ GHC.Types.Int var#_apW w2_sqV
              of _ { (# ipv_aph, ipv1_api #) ->
              case ipv1_api of _ { GHC.Types.I# x_aoV ->
              $wa1_sr8 (GHC.Prim.+# x_aoV ds_Xok) ipv_aph
              }
              }
              }
              };
            0 -> (# w2_sqV, Foo.foo2 #)
          }; } in
    $wa1_sr8 ww_sr3 w1_sr5

Foo.foo1 [InlPrag=INLINE[0]]
  :: forall s_agY.
     Foo.Vec s_agY
     -> GHC.Types.Int
     -> GHC.Prim.State# s_agY
     -> (# GHC.Prim.State# s_agY, GHC.Types.Int #)
[GblId,
 Arity=3,
 Caf=NoCafRefs,
 Str=DmdType <L,U(U(U))><S(S),U(U)><L,U>,
 Unf=Unf{Src=Worker=Foo.$wa, TopLvl=True, Arity=3, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
         Tmpl= \ (@ s_agY)
                 (w_sr0 [Occ=Once] :: Foo.Vec s_agY)
                 (w1_sr1 [Occ=Once!] :: GHC.Types.Int)
                 (w2_sr5 [Occ=Once] :: GHC.Prim.State# s_agY) ->
                 case w1_sr1 of _ { GHC.Types.I# ww_sr3 [Occ=Once] ->
                 Foo.$wa @ s_agY w_sr0 ww_sr3 w2_sr5
                 }}]
Foo.foo1 =
  \ (@ s_agY)
    (w_sr0 :: Foo.Vec s_agY)
    (w1_sr1 :: GHC.Types.Int)
    (w2_sr5 :: GHC.Prim.State# s_agY) ->
    case w1_sr1 of _ { GHC.Types.I# ww_sr3 ->
    Foo.$wa @ s_agY w_sr0 ww_sr3 w2_sr5
    }

Foo.foo
  :: forall s_afc.
     Foo.Vec s_afc -> GHC.Types.Int -> GHC.ST.ST s_afc GHC.Types.Int
[GblId,
 Arity=3,
 Caf=NoCafRefs,
 Str=DmdType <L,U(U(U))><S(S),U(U)><L,U>,
 Unf=Unf{Src=InlineStable, TopLvl=True, Arity=0, Value=True,
         ConLike=True, WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)
         Tmpl= Foo.foo1
               `cast` (forall s_agY.
                       <Foo.Vec s_agY>
                       -> <GHC.Types.Int>
                       -> Sym <(GHC.ST.NTCo:ST[0] <s_agY> <GHC.Types.Int>)>
                       :: (forall s_agY.
                           Foo.Vec s_agY -> GHC.Types.Int -> GHC.ST.STRep s_agY GHC.Types.Int)
                            ~#
                          (forall s_agY.
                           Foo.Vec s_agY -> GHC.Types.Int -> GHC.ST.ST s_agY GHC.Types.Int))}]
Foo.foo =
  Foo.foo1
  `cast` (forall s_agY.
          <Foo.Vec s_agY>
          -> <GHC.Types.Int>
          -> Sym <(GHC.ST.NTCo:ST[0] <s_agY> <GHC.Types.Int>)>
          :: (forall s_agY.
              Foo.Vec s_agY -> GHC.Types.Int -> GHC.ST.STRep s_agY GHC.Types.Int)
               ~#
             (forall s_agY.
              Foo.Vec s_agY -> GHC.Types.Int -> GHC.ST.ST s_agY GHC.Types.Int))
Note: See TracTickets for help on using tickets.