Commit 869df3c7 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Performance test for Trac #5321

parent 4976d0e0
{-# OPTIONS_GHC -fcontext-stack=1000 #-}
{-# LANGUAGE
FlexibleContexts, FlexibleInstances, FunctionalDependencies,
MultiParamTypeClasses, OverlappingInstances, TypeSynonymInstances,
TypeOperators, UndecidableInstances, TypeFamilies #-}
module T5321FD where
-------- USES FUNCTIONAL DEPENDENCIES -------------
-- Our running example, for simplicity's sake, is a type-level map of a
-- single function. For reference, here is the code for a simple
-- value-level map of a single function.
-- vfoo = id
-- mapfoo (x : xs) = vfoo x : mapfoo xs
-- mapfoo [] = []
-- Because Haskell is a lazy language, this runs in O(n) time and constant stack.
-- We now lift map to the type level, to operate over HLists.
-- First, the basic HList types
infixr 3 :*
data x :* xs = x :* xs deriving Show
data HNil = HNil deriving Show
-- Next, a large boring HList
-- Adds ten cells
addData x = i :* i :* d :* d :* s :*
i :* i :* d :* d :* s :*
x
where i = 1 :: Int
d = 1 :: Double
s = ""
-- Has 70 cells.
sampleData = addData $ addData $ addData $ addData $ addData $
addData $ addData $
HNil
-- Next, a simple polymorphic function to map
class Foo x y | x -> y
where foo :: x -> y
foo = undefined
instance Foo Int Double
instance Foo Double Int
instance Foo String String
------------------------
-- Now, our map
class HMapFoo1 as bs | as -> bs where
hMapFoo1 :: as -> bs
instance (Foo a b, HMapFoo1 as bs) => HMapFoo1 (a :* as) (b :* bs) where
hMapFoo1 (x :* xs) = foo x :* hMapFoo1 xs
instance HMapFoo1 HNil HNil where
hMapFoo1 _ = HNil
-- If we enable the following line, compilation time is ~ 9 seconds.
testHMapFoo1 = hMapFoo1 sampleData
------------------------
class HMapFoo2 acc as bs | acc as -> bs where
hMapFoo2 :: acc -> as -> bs
instance (Foo a b, HMapFoo2 (b :* bs) as res) => HMapFoo2 bs (a :* as) res where
hMapFoo2 acc (x :* xs) = hMapFoo2 (foo x :* acc) xs
instance HMapFoo2 acc HNil acc where
hMapFoo2 acc _ = acc
-- If we enable the following line, compilation time is a much more satisfying ~0.5s.
testHMapFoo2 = hMapFoo2 HNil sampleData
------------------------
-- But wait, there's trouble on the horizon! Consider the following version:
class HMapFoo3 acc as bs | acc as -> bs where
hMapFoo3 :: acc -> as -> bs
instance (HMapFoo3 (b :* bs) as res, Foo a b) => HMapFoo3 bs (a :* as) res where
hMapFoo3 acc (x :* xs) = hMapFoo3 (foo x :* acc) xs
instance HMapFoo3 acc HNil acc where
hMapFoo3 acc _ = acc
-- The only difference between hMapFoo2 and hMapFoo3 is that the order of
-- constraints on the inductive case has been reversed, with the
-- recursive constraint first and the immediately checkable constraint
-- second. Now, if we enable the following line, compilation time rockets
-- to ~6s!
testHMapFoo3 = hMapFoo3 HNil sampleData
{-# OPTIONS_GHC -fcontext-stack=1000 #-}
{-# LANGUAGE
FlexibleContexts, FlexibleInstances, FunctionalDependencies,
MultiParamTypeClasses, OverlappingInstances, TypeSynonymInstances,
TypeOperators, UndecidableInstances, TypeFamilies #-}
module T5321Fun where
-- As the below code demonstrates, the same issues demonstrated with
-- Functional Dependencies also appear with Type Families, although less
--horribly, as their code-path seems more optimized in the current
-- constraint solver:
-- Our running example, for simplicity's sake, is a type-level map of a
-- single function. For reference, here is the code for a simple
-- value-level map of a single function.
-- > vfoo = id
-- > mapfoo (x : xs) = vfoo x : mapfoo xs
-- > mapfoo [] = []
-- Because Haskell is a lazy language, this runs in O(n) time and constant stack.
-- We now lift map to the type level, to operate over HLists.
-- First, the basic HList types
infixr 3 :*
data x :* xs = x :* xs deriving Show
data HNil = HNil deriving Show
-- Next, a large boring HList
-- Adds ten cells
addData x = i :* i :* d :* d :* s :*
i :* i :* d :* d :* s :*
x
where i = 1 :: Int
d = 1 :: Double
s = ""
-- Has 70 cells.
sampleData = addData $ addData $ addData $ addData $ addData $
addData $ addData $
HNil
class TFoo x where
type TFooFun x
tfoo :: x -> TFooFun x
tfoo = undefined
instance TFoo Int where
type TFooFun Int = Double
instance TFoo Double where
type TFooFun Double = Int
instance TFoo String where
type TFooFun String = String
class THMapFoo1 as where
type THMapFoo1Res as
thMapFoo1 :: as -> THMapFoo1Res as
instance (TFoo a, THMapFoo1 as) => THMapFoo1 (a :* as) where
type THMapFoo1Res (a :* as) = TFooFun a :* THMapFoo1Res as
thMapFoo1 (x :* xs) = tfoo x :* thMapFoo1 xs
instance THMapFoo1 HNil where
type THMapFoo1Res HNil = HNil
thMapFoo1 _ = HNil
-- The following, when enabled, takes ~3.5s. This demonstrates that slowdown occurs with type families as well.
testTHMapFoo1 = thMapFoo1 sampleData
class THMapFoo2 acc as where
type THMapFoo2Res acc as
thMapFoo2 :: acc -> as -> THMapFoo2Res acc as
instance (TFoo a, THMapFoo2 (TFooFun a :* acc) as) => THMapFoo2 acc (a :* as) where
type THMapFoo2Res acc (a :* as) = THMapFoo2Res (TFooFun a :* acc) as
thMapFoo2 acc (x :* xs) = thMapFoo2 (tfoo x :* acc) xs
instance THMapFoo2 acc HNil where
type THMapFoo2Res acc HNil = acc
thMapFoo2 acc _ = acc
-- The following, when enabled, takes ~0.6s. This demonstrates that the
-- tail recursive transform fixes the slowdown with type families just as
-- with fundeps.
testTHMapFoo2 = thMapFoo2 HNil sampleData
class THMapFoo3 acc as where
type THMapFoo3Res acc as
thMapFoo3 :: acc -> as -> THMapFoo3Res acc as
instance (THMapFoo3 (TFooFun a :* acc) as, TFoo a) => THMapFoo3 acc (a :* as) where
type THMapFoo3Res acc (a :* as) = THMapFoo3Res (TFooFun a :* acc) as
thMapFoo3 acc (x :* xs) = thMapFoo3 (tfoo x :* acc) xs
instance THMapFoo3 acc HNil where
type THMapFoo3Res acc HNil = acc
thMapFoo3 acc _ = acc
-- The following, when enabled, also takes ~0.6s. This demonstrates that,
-- unlike the fundep case, the order of type class constraints does not,
-- in this instance, affect the performance of type families.
testTHMapFoo3 = thMapFoo3 HNil sampleData
......@@ -206,3 +206,29 @@ test('T783',
450000000))
],
compile,[''])
test('T5321Fun',
[ only_ways(['normal']), # no optimisation for this one
# expected value: 175,569,928 (x86/Linux)
if_wordsize(32,
compiler_stats_num_field('bytes allocated', 1000000000,
1100000000)),
# expected value: 390895576 (amd64/Linux):
if_wordsize(64,
compiler_stats_num_field('bytes allocated', 2000000000,
2200000000))
],
compile,[''])
test('T5321FD',
[ only_ways(['normal']), # no optimisation for this one
# expected value: 175,569,928 (x86/Linux)
if_wordsize(32,
compiler_stats_num_field('bytes allocated', 500000000,
600000000)),
# expected value: 390895576 (amd64/Linux):
if_wordsize(64,
compiler_stats_num_field('bytes allocated', 1000000000,
1200000000))
],
compile,[''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment