Opened 12 months ago

Closed 11 months ago

Last modified 10 months ago

#8848 closed bug (fixed)

Warning: Rule too complicated to desugar

Reported by: carter Owned by:
Priority: normal Milestone: 7.10.1
Component: Compiler Version: 7.8.1-rc2
Keywords: Cc:
Operating System: Unknown/Multiple Architecture: Unknown/Multiple
Type of failure: None/Unknown Test Case: simplCore/should_compile/T8848, T8848a
Blocked By: Blocking:
Related Tickets: Differential Revisions:

Description

I've a very very modest application of Specialize to fixed sized lists in some of my code
which seems to trip up the specialization machinery. Is there any flags I can pass GHC to make sure it doesn't give up on these specialize calls?

is the only work around to write my own monomorphic versions and add some hand written rewrite rules?!

rc/Numerical/Types/Shape.hs:225:1: Warning:
    RULE left-hand side too complicated to desugar
      let {
        $dFunctor_a3XB :: Functor (Shape ('S 'Z))
        [LclId, Str=DmdType]
        $dFunctor_a3XB =
          Numerical.Types.Shape.$fFunctorShape @ 'Z $dFunctor_a3Rn } in
      map2
        @ a
        @ b
        @ c
        @ ('S ('S 'Z))
        (Numerical.Types.Shape.$fApplicativeShape
           @ ('S 'Z)
           (Numerical.Types.Shape.$fFunctorShape @ ('S 'Z) $dFunctor_a3XB)
           (Numerical.Types.Shape.$fApplicativeShape
              @ 'Z $dFunctor_a3XB Numerical.Types.Shape.$fApplicativeShape0))

src/Numerical/Types/Shape.hs:226:1: Warning:
    RULE left-hand side too complicated to desugar
      let {
        $dFunctor_a3XG :: Functor (Shape ('S 'Z))
        [LclId, Str=DmdType]
        $dFunctor_a3XG =
          Numerical.Types.Shape.$fFunctorShape @ 'Z $dFunctor_a3Rn } in
      let {
        $dFunctor_a3XF :: Functor (Shape ('S ('S 'Z)))
        [LclId, Str=DmdType]
        $dFunctor_a3XF =
          Numerical.Types.Shape.$fFunctorShape @ ('S 'Z) $dFunctor_a3XG } in
      map2
        @ a
        @ b
        @ c
        @ ('S ('S ('S 'Z)))
        (Numerical.Types.Shape.$fApplicativeShape
           @ ('S ('S 'Z))
           (Numerical.Types.Shape.$fFunctorShape
              @ ('S ('S 'Z)) $dFunctor_a3XF)
           (Numerical.Types.Shape.$fApplicativeShape
              @ ('S 'Z)
              $dFunctor_a3XF
              (Numerical.Types.Shape.$fApplicativeShape
                 @ 'Z $dFunctor_a3XG Numerical.Types.Shape.$fApplicativeShape0)))

the associated code (smashed into a single module ) is

{-# LANGUAGE DataKinds, GADTs, TypeFamilies,
              ScopedTypeVariables  #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Numerical.Types.Shape where

import GHC.Magic 
import Data.Data 
import Data.Typeable()

import Data.Type.Equality

import qualified Data.Monoid  as M 
import qualified Data.Functor as Fun 
import qualified  Data.Foldable as F
import qualified Control.Applicative as A 


import Prelude hiding  (foldl,foldr,init,scanl,scanr,scanl1,scanr1)




data Nat = S !Nat  | Z 
    deriving (Eq,Show,Read,Typeable,Data)    

#if defined(__GLASGOW_HASKELL_) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable 'Z
deriving instance Typeable 'S
#endif



type family n1 + n2 where
  Z + n2 = n2
  (S n1') + n2 = S (n1' + n2)
 
-- singleton for Nat
data SNat :: Nat -> * where
  SZero :: SNat Z
  SSucc :: SNat n -> SNat (S n)
 
--gcoerce :: (a :~: b) -> ((a ~ b) => r) -> r
--gcoerce Refl x = x
--gcoerce = gcastWith
 
-- inductive proof of right-identity of +
plus_id_r :: SNat n -> ((n + Z) :~: n)
plus_id_r SZero = Refl
plus_id_r (SSucc n) = gcastWith (plus_id_r n) Refl
 
-- inductive proof of simplification on the rhs of +
plus_succ_r :: SNat n1 -> Proxy n2 -> ((n1 + (S n2)) :~: (S (n1 + n2)))
plus_succ_r SZero _ = Refl
plus_succ_r (SSucc n1) proxy_n2 = gcastWith (plus_succ_r n1 proxy_n2) Refl



type N0 = Z

type N1= S N0 

type N2 = S N1

type N3 = S N2 

type N4 = S N3

type N5 = S N4

type N6 = S N5

type N7 = S N6

type N8 = S N7  

type N9 = S N8

type N10 = S N9  



{-
Need to sort out packed+unboxed vs generic approaches
see ShapeAlternatives/ for 

-}

infixr 3 :*
    
 {-
the concern basically boils down to "will it specialize / inline well"

 -}

newtype At a = At  a
     deriving (Eq, Ord, Read, Show, Typeable, Functor)


data Shape (rank :: Nat) a where 
    Nil  :: Shape Z a
    (:*) ::  !(a) -> !(Shape r a ) -> Shape  (S r) a
        --deriving  (Show)

#if defined(__GLASGOW_HASKELL_) && (__GLASGOW_HASKELL__ >= 707)
deriving instance Typeable Shape 
#endif


instance  Eq (Shape Z a) where
    (==) _ _ = True 
instance (Eq a,Eq (Shape s a))=> Eq (Shape (S s) a )  where 
    (==)  (a:* as) (b:* bs) =  (a == b) && (as == bs )   

instance  Show (Shape Z a) where 
    show _ = "Nil"

instance (Show a, Show (Shape s a))=> Show (Shape (S s) a) where
    show (a:* as) = show a  ++ " :* " ++ show as 

-- at some point also try data model that
-- has layout be dynamicly reified, but for now
-- keep it phantom typed for sanity / forcing static dispatch.
-- NB: may need to make it more general at some future point
--data Strided r a lay = Strided {   getStrides :: Shape r a   }




{-# INLINE reverseShape #-}
reverseShape :: Shape n a -> Shape n a 
reverseShape Nil = Nil
reverseShape list = go SZero Nil list
  where
    go :: SNat n1 -> Shape n1  a-> Shape n2 a -> Shape (n1 + n2) a
    go snat acc Nil = gcastWith (plus_id_r snat) acc
    go snat acc (h :* (t :: Shape n3 a)) =
      gcastWith (plus_succ_r snat (Proxy :: Proxy n3))
              (go (SSucc snat) (h :* acc) t)



instance Fun.Functor (Shape Z) where
    fmap  = \ _ Nil -> Nil 
    --{-# INLINE fmap #-}

instance  (Fun.Functor (Shape r)) => Fun.Functor (Shape (S r)) where
    fmap  = \ f (a :* rest) -> f a :* Fun.fmap f rest 
    --{-# INLINE fmap  #-}
instance  A.Applicative (Shape Z) where 
    pure = \ _ -> Nil
    --{-# INLINE pure  #-}
    (<*>) = \ _  _ -> Nil 
    --{-# INLINE (<*>) #-}
instance  A.Applicative (Shape r)=> A.Applicative (Shape (S r)) where     
    pure = \ a -> a :* (A.pure a)
    --{-# INLINE pure #-}
    (<*>) = \ (f:* fs) (a :* as) ->  f a :* (inline (A.<*>)) fs as 
    --{-# INLINE (<*>) #-}
instance F.Foldable (Shape Z) where
    foldMap = \ _ _ -> M.mempty
    --{-# fold #-}
    foldl = \ _ init  _ -> init 
    foldr = \ _ init _ -> init 
    foldr' = \_ !init _ -> init 
    foldl' = \_ !init _ -> init   


instance (F.Foldable (Shape r))  => F.Foldable (Shape (S r)) where
    foldMap = \f  (a:* as) -> f a M.<> F.foldMap f as 
    foldl' = \f !init (a :* as) -> let   next = f  init a   in     next `seq`  F.foldl f next as 
    foldr' = \f !init (a :* as ) -> f a $!  F.foldr f init as               
    foldl = \f init (a :* as) -> let   next = f  init a  in    F.foldl f next as 
    foldr = \f init (a :* as ) -> f a $  F.foldr f init as     



--
map2 :: (A.Applicative (Shape r))=> (a->b ->c) -> (Shape r a) -> (Shape r b) -> (Shape r c )
map2 = \f l r -> A.pure f A.<*>  l  A.<*> r 
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape Z a )-> Shape Z b -> Shape Z c #-}
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S Z) a )-> Shape (S Z) b -> Shape (S Z) c #-}
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S (S Z)) a )-> Shape (S (S Z)) b -> Shape (S (S Z)) c #-}
{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S (S(S Z))) a )-> Shape (S (S (S Z))) b -> Shape (S (S(S Z))) c #-}
-- {-# INLINABLE map2 #-}



Change History (11)

comment:1 Changed 11 months ago by Simon Peyton Jones <simonpj@…>

In 41ba7ccb742278de0abf32cb7571c71b150997a3/ghc:

Improve the desugaring of RULE left-hand-sides (fixes Trac #8848)

I've added detailed comments with
  Note [Decomposing the left-hand side of a RULE]

The result is a noticeable improvement.  Previously

 * we rejected a perfectly decent SPECIALISE (Trac #8848)

 * and for something like
      f :: (Eq a) => b -> a -> a
      {-# SPECIALISE f :: b -> [Int] -> [Int] #-}
   we ended up with
      RULE  f ($fdEqList $dfEqInt) = f_spec
   whereas we wanted
      RULES forall (d:Eq [Int]). f d = f_spec

comment:2 Changed 11 months ago by Simon Peyton Jones <simonpj@…>

comment:3 Changed 11 months ago by simonpj

  • Resolution set to fixed
  • Status changed from new to closed
  • Test Case set to simplCore/should_compile/T8848, T8848a

Thank yuu for reporting this. It's led me to an altogether better treatment for the LHS of rules.

Simon

comment:4 Changed 11 months ago by carter

Thank you! Glad I could accidentally help.

Any chance this might land in 7.8? :)
currently my options otherwise are either

  1. unconditionally inline everything (with the associated costs in code complexity)
  2. Or write my own hand unrolled routine that has some fast paths for small size inputs, that also gets unconditionally inlined

comment:5 Changed 11 months ago by simonpj

No, it's too late for 7.8 I'm afraid. Possibly 7.8.2.

Maybe you can try

{-# RULE map2 = map2_spec #-}
map2_spec :: (a->b->c)-> (Shape Z a )-> Shape Z b -> Shape Z c 
map2_spec = inline map2

and so on for the other cases. (Untested.)

Simon

comment:6 Changed 11 months ago by carter

figured as such, glad things are shipping! 7.8.2 would be fine

Yeah, I'll be trying out some ideas like that rules soon

Last edited 11 months ago by carter (previous) (diff)

comment:7 Changed 11 months ago by carter

  • Milestone set to 7.8.2

setting milestone for 7.8.2 so its on the list when that rolls around

Last edited 11 months ago by carter (previous) (diff)

comment:8 Changed 11 months ago by thoughtpolice

  • Milestone changed from 7.8.2 to 7.8.3
  • Status changed from closed to merge

This shouldn't be marked fixed. 7.8.2 will be a critical bugfix release, but I think we'll punt this for consideration to 7.8.3 instead.

comment:9 Changed 11 months ago by thoughtpolice

  • Status changed from merge to closed

This didn't properly merge to the 7.8 branch - I think some of Joachim's work (some which probably should not be merged) caused a conflict, and I haven't traced down exactly which commits those are.

As it is, I'm inclined to not merge this, then. I'm marking as fixed - please let me know if someone disagrees.

comment:10 Changed 11 months ago by thoughtpolice

  • Milestone changed from 7.8.3 to 7.10.1

comment:11 Changed 10 months ago by carter

@thoughtpolice, if there was a path to getting this into 7.8.3 that I could help with making happen, i'm willing to help do some leg work (though it touches on pieces of GHC i'm not yet familiar with).

I believe I can work around this limitation in SPECIALIZE for now, but if there was a way to help get it into 7.8.3, please let me know.

(though i'll be excited to revisit my engineering on 7.9 / 7.10 on way or another)

Note: See TracTickets for help on using tickets.