Opened 15 months ago

Closed 13 months ago

Last modified 2 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 (16)

comment:1 Changed 14 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 14 months ago by Simon Peyton Jones <simonpj@…>

comment:3 Changed 14 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 14 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 14 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 14 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 14 months ago by carter (previous) (diff)

comment:7 Changed 14 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 14 months ago by carter (previous) (diff)

comment:8 Changed 14 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 13 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 13 months ago by thoughtpolice

  • Milestone changed from 7.8.3 to 7.10.1

comment:11 Changed 13 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)

comment:12 Changed 2 months ago by yongqli

It is possible that

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

creates an infinite loop, because we end up with

map2_spec = inline map2_spec

?

My program seems to hang after trying it, but GHC does not throw <<loop>>.

comment:13 Changed 2 months ago by yongqli

@carter, were you able to get a workaround to work? We are experiencing the same issue.

comment:14 Changed 2 months ago by thomie

@yongqli A fix for this issue is supposed to be in 7.10. Please try your code with release candidate 2.

comment:15 Changed 2 months ago by yongqli

@thomie: We are stuck on GHC 7.8 for now :(.

For what it's worth, I was able to work around the problem using the RULES method. I set the rule to fire after phase 1, so that "map2" would have already been inlined away, thus preventing an infinite loop.

comment:16 Changed 2 months ago by simonpj

I don't think that comment:12 has much to do with this ticket although it's hard to tell without a repro case.

It's easy to make GHC diverge using rules. Most crudely

{-# RULE map2 = map2 #-}

would do it, by making the rule fire repeatedly. Your code looks sort of like that, although as I say it is hard to tell.

You can see more of what is happening with -ddump-inlinings and -ddump-rule-firings.

For now I think this probably a user error.

Simon

Note: See TracTickets for help on using tickets.