Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
3eb85d3d
Commit
3eb85d3d
authored
Aug 03, 2011
by
Simon Peyton Jones
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Test Trac
#5359
parent
41e5e783
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
153 additions
and
1 deletion
+153
-1
testsuite/tests/simplCore/should_compile/T5359a.hs
testsuite/tests/simplCore/should_compile/T5359a.hs
+88
-0
testsuite/tests/simplCore/should_compile/T5359b.hs
testsuite/tests/simplCore/should_compile/T5359b.hs
+62
-0
testsuite/tests/simplCore/should_compile/all.T
testsuite/tests/simplCore/should_compile/all.T
+3
-1
No files found.
testsuite/tests/simplCore/should_compile/T5359a.hs
0 → 100644
View file @
3eb85d3d
{-# LANGUAGE BangPatterns, Rank2Types, MagicHash, UnboxedTuples #-}
module
T5359a
(
linesT
)
where
import
GHC.Base
import
GHC.Word
import
GHC.ST
(
ST
(
..
),
runST
)
nullT
::
Text
->
Bool
nullT
(
Text
_
_
len
)
=
len
<=
0
{-# INLINE [1] nullT #-}
spanT
::
(
Char
->
Bool
)
->
Text
->
(
Text
,
Text
)
spanT
p
t
@
(
Text
arr
off
len
)
=
(
textP
arr
off
k
,
textP
arr
(
off
+
k
)
(
len
-
k
))
where
k
=
loop
0
loop
!
i
|
i
>=
len
||
not
(
p
c
)
=
i
|
otherwise
=
loop
(
i
+
d
)
where
Iter
c
d
=
iter
t
i
{-# INLINE spanT #-}
linesT
::
Text
->
[
Text
]
linesT
ps
|
nullT
ps
=
[]
|
otherwise
=
h
:
if
nullT
t
then
[]
else
linesT
(
unsafeTail
t
)
where
(
h
,
t
)
=
spanT
(
/=
'
\n
'
)
ps
{-# INLINE linesT #-}
unsafeTail
::
Text
->
Text
unsafeTail
t
@
(
Text
arr
off
len
)
=
Text
arr
(
off
+
d
)
(
len
-
d
)
where
d
=
iter_
t
0
{-# INLINE unsafeTail #-}
data
Iter
=
Iter
{-# UNPACK #-}
!
Char
{-# UNPACK #-}
!
Int
iter
::
Text
->
Int
->
Iter
iter
(
Text
arr
_
_
)
i
=
Iter
(
unsafeChrT
m
)
1
where
m
=
unsafeIndex
arr
i
{-# INLINE iter #-}
iter_
::
Text
->
Int
->
Int
iter_
(
Text
arr
off
_
)
i
|
m
<
0xD800
||
m
>
0xDBFF
=
1
|
otherwise
=
2
where
m
=
unsafeIndex
arr
(
off
+
i
)
{-# INLINE iter_ #-}
data
Text
=
Text
{-# UNPACK #-}
!
Array
{-# UNPACK #-}
!
Int
{-# UNPACK #-}
!
Int
text
::
Array
->
Int
->
Int
->
Text
text
arr
off
len
=
Text
arr
off
len
{-# INLINE text #-}
emptyT
::
Text
emptyT
=
Text
empty
0
0
{-# INLINE [1] emptyT #-}
textP
::
Array
->
Int
->
Int
->
Text
textP
arr
off
len
|
len
==
0
=
emptyT
|
otherwise
=
text
arr
off
len
{-# INLINE textP #-}
unsafeChrT
::
Word16
->
Char
unsafeChrT
(
W16
#
w
#
)
=
C
#
(
chr
#
(
word2Int
#
w
#
))
{-# INLINE unsafeChrT #-}
data
Array
=
Array
ByteArray
#
data
MArray
s
=
MArray
(
MutableByteArray
#
s
)
new
::
forall
s
.
Int
->
ST
s
(
MArray
s
)
new
n
@
(
I
#
len
#
)
|
n
<
0
||
n
/=
0
=
error
$
"Data.Text.Array.new: size overflow"
|
otherwise
=
ST
$
\
s1
#
->
case
newByteArray
#
len
#
s1
#
of
(
#
s2
#
,
marr
#
#
)
->
(
#
s2
#
,
MArray
marr
#
#
)
{-# INLINE new #-}
unsafeFreeze
::
MArray
s
->
ST
s
Array
unsafeFreeze
(
MArray
maBA
)
=
ST
$
\
s
#
->
(
#
s
#
,
Array
(
unsafeCoerce
#
maBA
)
#
)
{-# INLINE unsafeFreeze #-}
unsafeIndex
::
Array
->
Int
->
Word16
unsafeIndex
(
Array
aBA
)
(
I
#
i
#
)
=
case
indexWord16Array
#
aBA
i
#
of
r
#
->
(
W16
#
r
#
)
{-# INLINE unsafeIndex #-}
empty
::
Array
empty
=
runST
(
new
0
>>=
unsafeFreeze
)
testsuite/tests/simplCore/should_compile/T5359b.hs
0 → 100644
View file @
3eb85d3d
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
module
T5359b
where
-----------------------------------------------------------------------------
-- Base
-----------------------------------------------------------------------------
infixr
5
:+:
infixr
6
:*:
data
U
=
U
data
a
:+:
b
=
L
a
|
R
b
data
a
:*:
b
=
a
:*:
b
newtype
Rec
a
=
Rec
a
class
Representable
a
where
type
Rep
a
to
::
Rep
a
->
a
from
::
a
->
Rep
a
data
Tree
=
Leaf
|
Bin
Int
Tree
Tree
instance
Representable
Tree
where
type
Rep
Tree
=
U
:+:
(
Rec
Int
:*:
Rec
Tree
:*:
Rec
Tree
)
from
(
Bin
x
l
r
)
=
R
((
Rec
x
:*:
Rec
l
:*:
Rec
r
))
from
Leaf
=
L
(
U
)
to
(
R
((
Rec
x
:*:
(
Rec
l
)
:*:
(
Rec
r
))))
=
Bin
x
l
r
to
(
L
(
U
))
=
Leaf
--------------------------------------------------------------------------------
-- Generic enum
--------------------------------------------------------------------------------
class
Enum'
a
where
enum'
::
[
a
]
instance
Enum'
U
where
enum'
=
undefined
instance
(
Enum'
a
)
=>
Enum'
(
Rec
a
)
where
enum'
=
undefined
instance
(
Enum'
f
,
Enum'
g
)
=>
Enum'
(
f
:+:
g
)
where
enum'
=
undefined
instance
(
Enum'
f
,
Enum'
g
)
=>
Enum'
(
f
:*:
g
)
where
enum'
=
undefined
-- This INLINE pragma is essential for the bug
{-# INLINE genum #-}
genum
::
(
Representable
a
,
Enum'
(
Rep
a
))
=>
[
a
]
-- The definition of genum is essential for the bug
genum
=
map
to
enum'
instance
Enum'
Tree
where
enum'
=
genum
instance
Enum'
Int
where
enum'
=
[]
-- This SPECIALISE pragma is essential for the bug
{-# SPECIALISE genum :: [Tree] #-}
testsuite/tests/simplCore/should_compile/all.T
View file @
3eb85d3d
...
...
@@ -124,4 +124,6 @@ test('T5168',
test
('
T5329
',
normal
,
compile
,
[''])
test
('
T5303
',
reqlib
('
mtl
'),
compile
,
[''])
# Coercion-optimiation test
test
('
T5342
',
normal
,
compile
,
[''])
# Lint error with -prof
test
('
T5342
',
normal
,
compile
,
[''])
# Lint error with -prof
test
('
T5359a
',
normal
,
compile
,
[''])
# Lint error with -O (OccurAnal)
test
('
T5359b
',
normal
,
compile
,
[''])
# Lint error with -O (OccurAnal)
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment