[GHC] #8848: Warning: Rule too complicated to desugar
GHC
ghc-devs at haskell.org
Tue Mar 4 18:25:57 UTC 2014
#8848: Warning: Rule too complicated to desugar
------------------------------------+-------------------------------------
Reporter: carter | Owner:
Type: bug | Status: new
Priority: normal | Milestone:
Component: Compiler | Version: 7.8.1-rc2
Keywords: | Operating System: Unknown/Multiple
Architecture: Unknown/Multiple | Type of failure: None/Unknown
Difficulty: Unknown | Test Case:
Blocked By: | Blocking:
Related Tickets: |
------------------------------------+-------------------------------------
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 #-}
}}}
--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/8848>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
More information about the ghc-tickets
mailing list