Commit 220a0b93 authored by Erik de Castro Lopo's avatar Erik de Castro Lopo
Browse files

Add test for #9646

Test Plan: Test that it passes git HEAD and fails with GHC 7.8.

Reviewers: bgamari, hvr, austin, goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D2009

GHC Trac Issues: #9646
parent f4f315a3
{-# LANGUAGE CPP #-}
#include "MachDeps.h"
#if __GLASGOW_HASKELL__ < 709
import GHC.Types
#endif
import StrictPrim
import Type
import Natural
main :: IO ()
main = do
let (a, b) = (1234, 2345)
(na, nb) = (mkSingletonNat a, mkSingletonNat b)
nc = timesNatural na nb
print $ fromNatural na
print $ fromNatural nb
print $ fromNatural nc
checkEtaCount
checkEtaCount :: IO ()
checkEtaCount = do
text <- readFile "Natural.dump-simpl"
let etaCount = length . filter (== "eta") $ words text
if etaCount > 0
then error $ "Error : Eta count (" ++ show etaCount ++ ") should 0."
else putStrLn "Test passed!"
mkSingletonNat :: Word -> Natural
mkSingletonNat x = runStrictPrim mkNat
where
mkNat :: StrictPrim s Natural
mkNat = do
marr <- newWordArray 1
writeWordArray marr 0 x
narr <- unsafeFreezeWordArray marr
return $ Natural 1 narr
fromNatural :: Natural -> Word
fromNatural (Natural _ arr) = indexWordArray arr 0
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
TEST_HC_OPTS += -O2 -dsuppress-uniques -dsuppress-all -ddump-to-file -ddump-ds \
-ddump-simpl -ddump-simpl-iterations -ddump-simpl-stats
clean :
$(RM) -f *.o *.hi *.dump* cbits/primitive-memops.o T9646
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
module Natural where
import Prelude hiding (Integer, abs, sum)
import StrictPrim
import Type
{-# NOINLINE timesNatural #-}
timesNatural :: Natural -> Natural -> Natural
timesNatural (Natural !n1 !arr1) (Natural !n2 !arr2) =
runStrictPrim $ do
maxOutLen <- return (1 + n1 + n2)
marr <- newWordArray maxOutLen
len <- preLoop marr
narr <- unsafeFreezeWordArray marr
return $! Natural len narr
where
preLoop marr = do
x <- indexWordArrayM arr1 0
y <- indexWordArrayM arr2 0
let (# cry, prod #) = timesWord2 x y
writeWordArray marr 0 prod
outerLoop1 1 marr 0 cry
outerLoop1 !nx !marr !carryhi !carrylo
| nx < n2 = do
(cryhi, crylo, sum) <- innerLoop1xi nx 0 0 carryhi carrylo
writeWordArray marr nx sum
outerLoop1 (nx + 1) marr cryhi crylo
| otherwise = outerLoop1a nx marr carryhi carrylo
outerLoop1a !nx !marr !carryhi !carrylo
| nx < n1 - 1 = do
(cryhi, crylo, sum) <- innerLoop1yi nx 0 0 carryhi carrylo
writeWordArray marr nx sum
outerLoop1a (nx + 1) marr cryhi crylo
| otherwise = outerLoop2 nx marr carryhi carrylo
innerLoop1xi !xi !yi !carryhi !carrylo !sum
| xi >= 0 = do
x <- indexWordArrayM arr1 xi
y <- indexWordArrayM arr2 yi
let (# !cry0, !prod #) = timesWord2 x y
(# !cry1, !sum1 #) = plusWord2 prod sum
(# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
!cryhi = plusWord carryhi tcryhi
innerLoop1xi (xi - 1) (yi + 1) cryhi crylo sum1
| otherwise = return $! (carryhi, carrylo, sum)
innerLoop1yi !xi !yi !carryhi !carrylo !sum
| yi < n2 = do
x <- indexWordArrayM arr1 xi
y <- indexWordArrayM arr2 yi
let (# !cry0, !prod #) = timesWord2 x y
(# !cry1, !sum1 #) = plusWord2 prod sum
(# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
!cryhi = plusWord carryhi tcryhi
innerLoop1yi (xi - 1) (yi + 1) cryhi crylo sum1
| otherwise = return $! (carryhi, carrylo, sum)
outerLoop2 !nx !marr !carryhi !carrylo
| nx < n1 + n2 - 1 = do
(cryhi, crylo, sum)
<- innerLoop2 (n1 - 1) (nx - n1 + 1) 0 carryhi carrylo
writeWordArray marr nx sum
outerLoop2 (nx + 1) marr cryhi crylo
| carrylo /= 0 = do
writeWordArray marr nx carrylo
return $! nx + 1
| otherwise = return $! nx
innerLoop2 !xi !yi !carryhi !carrylo !sum
| yi < n2 = do
x <- indexWordArrayM arr1 xi
y <- indexWordArrayM arr2 yi
let (# !cry0, !prod #) = timesWord2 x y
(# !cry1, !sum1 #) = plusWord2 prod sum
(# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
!cryhi = plusWord carryhi tcryhi
innerLoop2 (xi - 1) (yi + 1) cryhi crylo sum1
| otherwise = return $! (carryhi, carrylo, sum)
{-# LANGUAGE BangPatterns, CPP, MagicHash, NoImplicitPrelude, RankNTypes,
TypeFamilies, UnboxedTuples, UnliftedFFITypes #-}
module StrictPrim
( StrictPrim
, PrimMonad (..)
, runStrictPrim
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import GHC.Base
newtype StrictPrim s a
= StrictPrim (State# s -> (# State# s, a #))
instance Applicative (StrictPrim s) where
{-# INLINE pure #-}
pure = return
{-# INLINE (<*>) #-}
(<*>) a b = do f <- a ; v <- b ; return $! (f $! v)
instance Functor (StrictPrim s) where
{-# INLINE fmap #-}
fmap !f (StrictPrim !m) = StrictPrim $ \ !s ->
case m s of
(# !new_s,!r #) -> (# new_s, f $! r #)
instance Monad (StrictPrim s) where
{-# INLINE return #-}
return !x = StrictPrim ( \ !s -> (# s, x #))
{-# INLINE (>>) #-}
(!m) >> (!k) = do { _ <- m ; k }
{-# INLINE (>>=) #-}
(StrictPrim !m) >>= (!k) =
StrictPrim ( \ !s ->
case m s of
(# new_s, r #) -> case k r of
StrictPrim k2 -> k2 new_s
)
instance PrimMonad (StrictPrim s) where
type PrimState (StrictPrim s) = s
{-# INLINE primitive #-}
primitive = StrictPrim
{-# INLINE runStrictPrim #-}
runStrictPrim :: (forall s. StrictPrim s a) -> a
runStrictPrim !st =
case st of
StrictPrim st_rep ->
case st_rep realWorld# of
(# _, !r #) -> r
class Monad m => PrimMonad m where
type PrimState m
primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
#if __GLASGOW_HASKELL__ < 709
-- Grab this from Prelude (part of Base) because Base depends on this code.
($!) :: (a -> b) -> a -> b
f $! x = let !vx = x in f vx
#endif
{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
#include "MachDeps.h"
module Type where
import GHC.Prim
import GHC.Types
import StrictPrim
data Natural = Natural {-# UNPACK #-} !Int {-# UNPACK #-} !WordArray
data WordArray = WA ByteArray#
data MutableWordArray m = MWA (MutableByteArray# (PrimState m))
{-# INLINE newWordArray #-}
newWordArray :: (Monad m, PrimMonad m) => Int -> m (MutableWordArray m)
newWordArray !len = do
let !(I# n#) = len * sizeOfWord
primitive (\s# -> case newByteArray# n# s# of
(# s'#, arr# #) -> (# s'#, MWA arr# #))
{-# INLINE unsafeFreezeWordArray #-}
unsafeFreezeWordArray :: (Monad m, PrimMonad m)
=> MutableWordArray m -> m WordArray
unsafeFreezeWordArray !(MWA arr#) =
primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
(# s'#, arr'# #) -> (# s'#, WA arr'# #))
{-# INLINE indexWordArray #-}
indexWordArray :: WordArray -> Int -> Word
indexWordArray !(WA arr#) (I# i#) =
let w# = indexWordArray# arr# i# in W# w#
{-# INLINE indexWordArrayM #-}
indexWordArrayM :: Monad m => WordArray -> Int -> m Word
indexWordArrayM !(WA arr#) (I# i#) =
let w# = indexWordArray# arr# i# in
case W# w# of x -> return x
{-# INLINE writeWordArray #-}
writeWordArray :: (Monad m, PrimMonad m)
=> MutableWordArray m -> Int -> Word -> m ()
writeWordArray !(MWA arr#) (I# i#) (W# x#) =
primitive (\s# ->
case writeWordArray# arr# i# x# s# of
s'# -> (# s'#, () #))
{-# INLINE plusWord #-}
plusWord :: Word -> Word -> Word
plusWord (W# a) (W# b) =
let !s = plusWord# a b
in W# s
{-# INLINE plusWord2 #-}
plusWord2 :: Word -> Word -> (# Word, Word #)
plusWord2 (W# a) (W# b) =
let (# !c, !s #) = plusWord2# a b
in (# W# c, W# s #)
{-# INLINE plusWord2C #-}
plusWord2C :: Word -> Word -> Word -> (# Word, Word #)
plusWord2C (W# a) (W# b) (W# c) =
let (# !c1, !s1 #) = plusWord2# a b
(# !c2, !s2 #) = plusWord2# s1 c
!carry = plusWord# c1 c2
in (# W# carry, W# s2 #)
{-# INLINE timesWord2 #-}
timesWord2 :: Word -> Word -> (# Word, Word #)
timesWord2 (W# a) (W# b) =
let (# !ovf, !prod #) = timesWord2# a b
in (# W# ovf, W# prod #)
sizeOfWord :: Int
sizeOfWord = WORD_SIZE_IN_BITS `div` 8
#include <string.h>
#include "primitive-memops.h"
void hsprimitive_memset_Word (HsWord *p, ptrdiff_t off, size_t n, HsWord x)
{
p += off;
if (x == 0)
memset(p, 0, n * sizeof(HsWord));
else if (sizeof(HsWord) == sizeof(int)*2) {
int *q = (int *)p;
const int *r = (const int *)(void *)&x;
while (n>0) {
q[0] = r[0];
q[1] = r[1];
q += 2;
--n;
}
}
else {
while (n>0) {
*p++ = x;
--n;
}
}
}
#ifndef haskell_primitive_memops_h
#define haskell_primitive_memops_h
#include <stdlib.h>
#include <stddef.h>
#include <HsFFI.h>
void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord);
#endif
This is a test for https://ghc.haskell.org/trac/ghc/ticket/9646
The problem addressed in that ticket was that under some circumstances,
GHC < 7.10.3 was failing to perform eta reduction deterministically.
Compiling this code now (2016/03/16) under ghc-7.8.4 and git HEAD shows that
ghc-7.8.4 produces more complicated code, with a number of extra lambadas which
are completely absent in the fast version.
Git HEAD current produces:
letrec {
$wpoly_innerLoop2
$wpoly_innerLoop2 =
\ @ s ww ww1 ww2 ww3 ww4 w ->
case tagToEnum# (<# ww1 dt2) of _ {
False -> (# w, (W# ww2, W# ww3, W# ww4) #);
True ->
case indexWordArray# dt1 ww of w#2 { __DEFAULT ->
case indexWordArray# dt3 ww1 of w#3 { __DEFAULT ->
case timesWord2# w#2 w#3 of _ { (# ovf1, prod1 #) ->
case plusWord2# prod1 ww4 of _ { (# c, s1 #) ->
case plusWord2# ww3 ovf1 of _ { (# c1, s2 #) ->
case plusWord2# s2 c of _ { (# c2, s3 #) ->
$wpoly_innerLoop2
(-# ww 1#) (+# ww1 1#) (plusWord# ww2 (plusWord# c1 c2)) s3 s1 w
}
}
}
}
}
}
}; } in ....
whereas ghc-7.8, for the same block produces:
letrec {
$wpoly_innerLoop2
$wpoly_innerLoop2 =
\ @ s ww ww1 ww2 ww3 ww4 ->
case tagToEnum# (<# ww1 dt2) of _ {
False ->
let {
sum
sum = W# ww4 } in
let {
carrylo
carrylo = W# ww3 } in
let {
carryhi
carryhi = W# ww2 } in
let {
vx
vx = (carryhi, carrylo, sum) } in
(\ eta -> (# eta, vx #)) `cast` ...;
True ->
let {
ds3
ds3 =
case indexWordArray# dt1 ww of w#2 { __DEFAULT ->
let {
x
x = W# w#2 } in
(\ eta -> (# eta, x #)) `cast` ...
} } in
let {
lvl
lvl =
case indexWordArray# dt3 ww1 of w#2 { __DEFAULT ->
let {
x
x = W# w#2 } in
(\ eta -> (# eta, x #)) `cast` ...
} } in
let {
a
a = -# ww 1 } in
let {
a1
a1 = +# ww1 1 } in
(\ eta ->
case (ds3 `cast` ...) eta of _ { (# ipv, ipv3 #) ->
case (lvl `cast` ...) ipv of _ { (# ipv4, ipv5 #) ->
case ipv3 of _ { W# a2 ->
case ipv5 of _ { W# b ->
case timesWord2# a2 b of _ { (# ovf1, prod1 #) ->
case plusWord2# prod1 ww4 of _ { (# c, s1 #) ->
case plusWord2# ww3 ovf1 of _ { (# c1, s2 #) ->
case plusWord2# s2 c of _ { (# c2, s3 #) ->
(($wpoly_innerLoop2 a a1 (plusWord# ww2 (plusWord# c1 c2)) s3 s1)
`cast` ...)
ipv4
}
}
}
}
}
}
}
})
`cast` ...
}; } in ...
I suspect that in the ghc-7.8.4 case, the lambda:
(\ eta -> (# eta, x #)) `cast` ...
is preventing the inlining of the indexWordArray# operations.
Much of the code for this test was pulled from the primitive package:
https://hackage.haskell.org/package/primitive
test('T9646',
[when(fast(), skip), extra_clean(['Main.hi', 'Main.o'])],
multimod_compile_and_run,
['Main', ''])
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