Arity analysis could be better

Here's an example I tripped over while optimising Hoopl. Given the following source code:

-- | if the graph being analyzed is open at the entry, there must
--   be no other entry point, or all goes horribly wrong...
analyzeFwd
   :: forall n f e .  NonLocal n =>
      FwdPass FuelUniqSM n f
   -> MaybeC e [Label]
   -> Graph n e C -> Fact e f
   -> FactBase f
analyzeFwd FwdPass { fp_lattice = lattice,
                     fp_transfer = FwdTransfer3 (ftr, mtr, ltr) }
  entries g in_fact = graph g in_fact
  where
    graph :: Graph n e C -> Fact e f -> FactBase f
    graph (GMany entry blockmap NothingO)
      = case (entries, entry) of
         (NothingC, JustO entry)   -> block entry `cat` body (successors entry)
         (JustC entries, NothingO) -> body entries
         _ -> error "bogus GADT pattern match failure"
     where
       body  :: [Label] -> Fact C f -> Fact C f
       body entries f
         = fixpoint_anal Fwd lattice do_block entries blockmap f
         where
           do_block :: forall x . Block n C x -> FactBase f -> Fact x f
           do_block b fb = block b entryFact
             where entryFact = getFact lattice (entryLabel b) fb

    block :: forall e x . Block n e x -> f -> Fact x f
    block BNil            = id
    block (BlockCO n b)   = ftr n `cat` block b
    block (BlockCC l b n) = ftr l `cat` block b `cat` ltr n
    block (BlockOC   b n) =             block b `cat` ltr n

    block (BMiddle n)     = mtr n
    block (BCat b1 b2)    = block b1 `cat` block b2
    block (BHead h n)     = block h  `cat` mtr n
    block (BTail n t)     = mtr  n   `cat` block t

    {-# INLINE cat #-}
    cat ft1 ft2 = \f -> ft2 (ft1 f)

GHC does not eta-expand block, resulting in terrible code.

      block_s2bB [Occ=LoopBreaker]
        :: forall e1_aPa x_aPb.
           Compiler.Hoopl.Graph.Block n_aGr e1_aPa x_aPb
           -> f_aGs -> Compiler.Hoopl.Dataflow.Fact x_aPb f_aGs
      [LclId, Arity=1, Str=DmdType S]
      block_s2bB =
        \ (@ e1_a1g7)
          (@ x_a1g8)
          (ds1_d1Le :: Compiler.Hoopl.Graph.Block n_aGr e1_a1g7 x_a1g8) ->
          case ds1_d1Le of _ {
            Compiler.Hoopl.Graph.BlockCO rb1_d1QD rb2_d1QE n_aPo b_aPp ->
              let {
                a4_s2ri [Dmd=Just L]
                  :: f_aGs
                     -> Compiler.Hoopl.Dataflow.Fact Compiler.Hoopl.Graph.O f_aGs
                [LclId, Str=DmdType]
                a4_s2ri =
                  block_s2bB
                    @ Compiler.Hoopl.Graph.O @ Compiler.Hoopl.Graph.O b_aPp } in
              let {
                ft1_aPC [Dmd=Just L] :: f_aGs -> f_aGs
                [LclId, Str=DmdType]
                ft1_aPC = ww2_s2Dc n_aPo } in
              (\ (f_aPE :: f_aGs) -> a4_s2ri (ft1_aPC f_aPE))
              `cast` (<f_aGs>
                      -> Compiler.Hoopl.Dataflow.TFCo:R:FactOf
                           (Sym
                              (Compiler.Hoopl.Dataflow.TFCo:R:FactOf
                                 <f_aGs>) ; Compiler.Hoopl.Dataflow.Fact (Sym rb2_d1QE) <f_aGs>)
                      :: (f_aGs
                          -> Compiler.Hoopl.Dataflow.Fact
                               Compiler.Hoopl.Graph.O (Compiler.Hoopl.Dataflow.R:FactOf f_aGs))
                           ~#
                         (f_aGs
                          -> Compiler.Hoopl.Dataflow.R:FactOf
                               (Compiler.Hoopl.Dataflow.Fact x_a1g8 f_aGs)));

In order to eta-expand block, GHC would have to realise that graph is always called with 2 arguments, which means that block is always called with 2 arguments (even though it calls itself recursively with only one argument).

Trac metadata

Trac field	Value
Version	7.5
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture