Commit 7b93a3de authored by Simon Peyton Jones's avatar Simon Peyton Jones

Test Trac #8425

parent bbda6d52
{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, FlexibleInstances #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Arr (
Array(..), (!!!), array
) where
import GHC.Num
import GHC.ST
import GHC.Base
import Good
data Array e = Array !Int !Int Int (Array# e)
array :: (Int,Int) -> [(Int, e)] -> Array e
array (l,u) ies
= unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
unsafeArray :: (Int,Int) -> [(Int, e)] -> Array e
unsafeArray b ies = unsafeArray' b (rangeSize b) ies
unsafeArray' :: (Int,Int) -> Int -> [(Int, e)] -> Array e
unsafeArray' (l,u) n@(I# n#) ies =
if n == 0 then error "aa" else runST (ST $ \s1# ->
case newArray# n# arrEleBottom s1# of
(# s2#, marr# #) ->
foldr (fill marr#) (done l u n marr#) ies s2#)
{-# NOINLINE arrEleBottom #-}
arrEleBottom :: a
arrEleBottom = error "(Array.!): undefined array element"
unsafeAt :: Array e -> Int -> e
unsafeAt (Array _ _ _ arr#) (I# i#) =
case indexArray# arr# i# of (# e #) -> e
fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a
fill marr# (I# i#, e) next
= \s1# -> case writeArray# marr# i# e s1# of
s2# -> next s2#
done :: Int -> Int -> Int -> MutableArray# s e -> STRep s (Array e)
done l u n marr#
= \s1# -> case unsafeFreezeArray# marr# s1# of
(# s2#, arr# #) -> (# s2#, Array l u n arr# #)
instance Eq (Array e) where
(Array l1 _ _ _) == (Array l2 _ _ _) = l1 == l2
instance Ord (Array e) where
compare (Array l1 _ _ _) (Array l2 _ _ _) = compare l1 l2
{-# INLINE index #-}
index :: (Int,Int) -> Int -> Int
index (m,n) i | m <= i && i <= n = i - m
| otherwise = error "index out of range"
rangeSize :: (Int,Int) -> Int
rangeSize (l,h) = h - l + 1
{-# INLINE (!!!) #-}
(!!!) :: Array e -> Int -> e
arr@(Array l u _ _) !!! i = unsafeAt arr $ index (l,u) i
instance Good (Array Int) where
isGood (Array _ _ n _) = 0 < n
module Base (
Map(..)
, lookup
, empty
, insert
) where
import Prelude hiding (lookup)
import Good
empty :: Map k a
empty = Tip
data Map k a = Bin !k a !(Map k a) | Tip
insert :: Ord k => k -> a -> Map k a -> Map k a
insert = go
where
go :: Ord k => k -> a -> Map k a -> Map k a
go kx x Tip = singleton kx x
go kx x (Bin ky y r) =
case compare kx ky of
EQ -> Bin kx x r
LT -> Bin ky y (go kx x r)
GT -> Bin ky y (go kx x r)
{-# INLINABLE insert #-}
singleton :: k -> a -> Map k a
singleton k x = Bin k x Tip
lookup :: Eq k => k -> Map k a -> Maybe a
lookup = go
where
go x _ | x `seq` False = undefined
go _ Tip = Nothing
go k (Bin kx x r) = case k == kx of
False -> go k r
True -> Just x
{-# INLINABLE lookup #-}
instance Good k => Good (Map k a) where
isGood Tip = True
isGood (Bin k _ r) = isGood k && isGood r
module BuggyOpt
(
addSequence, -- induces inliner bug, but not used anywhere
) where
import M
import Prelude hiding (lookup)
addSequence :: Map (Array Int) Int -> Map (Array Int) Int
addSequence seqs =
seq (isJust (lookup seq_ seqs)) (insert seq_ 5 seqs)
seq_ = array (2,2) [ (2,3)]
module Good (Good(..)) where
class Good a where
isGood :: a -> Bool
module M (Array, (!!!), array, isJust, Map, lookup, insert, empty) where
import Arr (Array, (!!!), array)
import Base (Map, lookup, insert, empty)
import Prelude hiding (lookup)
isJust :: Maybe a -> Bool
isJust Nothing = False
isJust (Just _) = True
module Main where
import BuggyOpt() -- bug inducer!
import Prelude hiding (lookup)
import Good
import M
mkLin :: Array Int -> Map (Array Int) Int
mkLin mseqs =
(isJust (lookup mseqs empty)) `seq` (insert mseqs 1 empty)
main :: IO ()
main = print $ isGood $ mkLin (array (1,1) [ (1,array (3,3) [(3, 42)]) ]!!!1)
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
# Optimised only, we're testing the strictness analyser here
setTestOpts( only_ways(['optasm']) )
test('T8425', normal, multimod_compile_and_run, ['Main','-O2'])
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