Commit 23f47b15 authored by David Feuer's avatar David Feuer Committed by Ben Gamari
Browse files

Add T9630

This is not the most precise test, unfortunately, but it does
demonstrate a modest improvement in compiler residency as a
result of the specializer don't-loop patch. A rather less
realistic variation on this has somewhat more dramatic effects.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3656
parent ee923252
{-# LANGUAGE DeriveGeneric #-}
module T9630 where
import T9630a
import GHC.Generics
import Control.Applicative
data T = T () () () ()
()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
()()()()()()()()()()()()()()()()
deriving Generic
instance Serialize T where
get = to <$> gGet
put = gPut . from
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- | Modified from cereal, which is
-- Copyright : Lennart Kolmodin, Galois Inc. 2009
-- License : BSD3-style
module T9630a (
Serialize(..), GSerialize (..), Putter, Get
) where
import Data.ByteString.Builder (Builder)
import Data.ByteString as B
import GHC.Generics
import Control.Applicative (Applicative (..), (<$>))
class Serialize t where
put :: Putter t
get :: Get t
instance Serialize () where
put () = pure ()
get = pure ()
-- Generics
class GSerialize f where
gPut :: Putter (f a)
gGet :: Get (f a)
instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
gPut (a :*: b) = gPut a *> gPut b
gGet = (:*:) <$> gGet <*> gGet
instance GSerialize a => GSerialize (M1 i c a) where
gPut = gPut . unM1
gGet = M1 <$> gGet
instance Serialize a => GSerialize (K1 i a) where
gPut = put . unK1
gGet = K1 <$> get
-- Put
data PairS a = PairS a !Builder
newtype PutM a = Put { unPut :: PairS a }
type Put = PutM ()
type Putter a = a -> Put
instance Functor PutM where
fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
instance Applicative PutM where
pure a = Put (PairS a mempty)
m <*> k = Put $
let PairS f w = unPut m
PairS x w' = unPut k
in PairS (f x) (w `mappend` w')
-- Get
data Result r = Fail String B.ByteString
| Partial (B.ByteString -> Result r)
| Done r B.ByteString
newtype Get a = Get
{ unGet :: forall r. Input -> Buffer -> More
-> Failure r -> Success a r
-> Result r }
type Input = B.ByteString
type Buffer = Maybe B.ByteString
type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r
type Success a r = Input -> Buffer -> More -> a -> Result r
data More
= Complete
| Incomplete (Maybe Int)
deriving (Eq)
instance Functor Get where
fmap p m = Get $ \ s0 b0 m0 kf ks ->
unGet m s0 b0 m0 kf $ \ s1 b1 m1 a -> ks s1 b1 m1 (p a)
instance Applicative Get where
pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a
f <*> x = Get $ \ s0 b0 m0 kf ks ->
unGet f s0 b0 m0 kf $ \ s1 b1 m1 g ->
unGet x s1 b1 m1 kf $ \ s2 b2 m2 y -> ks s2 b2 m2 (g y)
......@@ -1152,3 +1152,14 @@ test('Naperian',
],
compile,
[''])
test ('T9630',
[ compiler_stats_num_field('max_bytes_used', # Note [residency]
[(wordsize(64), 41568168, 15)
# initial: 56955240
# 2017-06-07: 41568168 Stop the specialiser generating loopy code
]),
extra_clean(['T9630a.hi', 'T9630a.o'])
],
multimod_compile,
['T9630', '-v0 -O'])
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