[GHC] #9345: Data.List.inits is extremely slow

[GHC]

#9345: Data.List.inits is extremely slow
-------------------------------------+-------------------------------------
              Reporter:  dfeuer      |            Owner:
                  Type:  bug         |           Status:  new
              Priority:  high        |        Milestone:  7.8.4
             Component:              |          Version:  7.8.3
  libraries/base                     |         Keywords:
            Resolution:              |     Architecture:  Unknown/Multiple
      Operating System:              |       Difficulty:  Easy (less than 1
  Unknown/Multiple                   |  hour)
       Type of failure:  Runtime     |       Blocked By:
  performance bug                    |  Related Tickets:
             Test Case:              |
              Blocking:              |
Differential Revisions:              |
-------------------------------------+-------------------------------------

Comment (by nomeata):

 Thanks. I changed it to `foo = sum $ concat $ initsQ' $ [1..10000::Int]`
 (so that I don’t get any print-related stuff), and `-ddump-call-arity`
 gives me this code:

 {{{
 #!hs
 [LclId,
  Arity=2,
  CallArity=2,
  Str=DmdType,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
          ConLike=True, WorkFree=True, Expandable=True,
          Guidance=IF_ARGS [0 0] 150 0}]
 c =
   \ (x :: [Int]) (y [OS=OneShot] :: Int -> Int) ->
     letrec {
       go [Occ=LoopBreaker] :: [Int] -> Int -> Int
       [LclId,
        Arity=1,
        CallArity=1,
        Str=DmdType,
        Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=1, Value=True,
                ConLike=True, WorkFree=True, Expandable=True,
                Guidance=IF_ARGS [30] 110 60}]
       go =
         \ (ds :: [Int]) ->
           case ds of _ [Occ=Dead] {
             [] -> y;
             : y ys ->
               let {
                 ds1 [OS=OneShot] :: Int -> Int
                 [LclId,
                  Str=DmdType,
                  Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0,
 Value=False,
                          ConLike=False, WorkFree=False, Expandable=False,
                          Guidance=IF_ARGS [] 20 0}]
                 ds1 = go ys } in
               \ (ds2 :: Int) -> ds1 ($fNumInt_$c+ ds2 y)
           }; } in
     go x

 foo :: Int
 [LclIdX,
  Str=DmdType,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
          ConLike=False, WorkFree=False, Expandable=False,
          Guidance=IF_ARGS [] 634 0}]
 foo =
   c (++ ([]) (reverse1 ([]) ([])))
     (letrec {
        go [Occ=LoopBreaker] :: Int# -> Queue Int -> Int -> Int
        [LclId,
         Arity=2,
         CallArity=2,
         Str=DmdType,
         Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=2, Value=True,
                 ConLike=True, WorkFree=True, Expandable=True,
                 Guidance=IF_ARGS [80 20] 464 0}]
        go =
          \ (x :: Int#) (eta :: Queue Int) ->
            let {
              b :: Int
              [LclId,
               Str=DmdType,
               Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=True,
                       ConLike=True, WorkFree=True, Expandable=True,
                       Guidance=IF_ARGS [] 10 20}]
              b = I# x } in
            case eta of _ [Occ=Dead] { Queue dt f r ->
            let {
              a :: Word#
              [LclId,
               Str=DmdType,
               Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=False,
                       ConLike=False, WorkFree=False, Expandable=True,
                       Guidance=IF_ARGS [] 1 0}]
              a = plusWord# dt (__word 1) } in
            let {
              r :: [Int]
              [LclId,
               Str=DmdType,
               Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0, Value=True,
                       ConLike=True, WorkFree=True, Expandable=True,
                       Guidance=IF_ARGS [] 10 30}]
              r = : b r } in
            case word2Int# (popCnt# a) of _ [Occ=Dead] {
              __DEFAULT ->
                c (++ f (reverse1 r ([])))
                  (case x of wild {
                     __DEFAULT -> go (+# wild 1) (Queue a f r);
                     10000 -> \ (eta :: Int) -> eta
                   });
              1 ->
                let {
                  ipv :: [Int]
                  [LclId,
                   Str=DmdType,
                   Unf=Unf{Src=<vanilla>, TopLvl=False, Arity=0,
 Value=False,
                           ConLike=False, WorkFree=False, Expandable=False,
                           Guidance=IF_ARGS [] 60 0}]
                  ipv = ++ f (reverse1 r ([])) } in
                c (++ ipv (reverse1 ([]) ([])))
                  (case x of wild {
                     __DEFAULT -> go (+# wild 1) (Queue a ipv ([]));
                     10000 -> \ (eta :: Int) -> eta
                   })
            }
            }; } in
      go 1 a)
     (I# 0)
 }}}

 The `go` inside `foo` is the interesting function. Its type has three
 arguments, but its outermost lambda only takes two. This is common when
 fusing a left-fold. Only that Call Arity is not sufficient to see that
 we’d want this to be expanded to thre arguments (`CallArity=3`).

 Would `CallArity=3` be correct? Yes, because the recursive calls to `go`
 call it with two arguments, pass that to `c`, which calls it at most once
 (so no sharing could be lost) with at least one argument.

 Unfortunately, that information is currently not available to the call
 arity analysis (§5.1.1 in the paper linked above). Call Arity is a forward
 analysis, so it is hard to see how it could make use of that. And even if
 it did, it would still have to pass a function (in that case a PAP) to
 `c`... :-(

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