Arity analysis could be better

[simonmar]

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).