Dear bug chasers,
ghc-2.02 is unhappy with the following program (it essentially contains
a wonderful class definition for sets and a simple instance, ordered
list without duplicates):
===============================================================================
> module Set ( module Set )
> where
> import Prelude hiding ( filter )
> import qualified Prelude -- !!!!GHC bug
> import List ( genericLength, sort )
> data SeqView t a = Null
> | Cons a (t a)
> class Set set where
> empty :: (Ord a) => set a
> single :: (Ord a) => a -> set a --
>singleton
> add :: (Ord a) => a -> set a -> set a -- insert
> addWith :: (Ord a) => (a -> a -> a) -> a -> set a -> set a
> union :: (Ord a) => set a -> set a -> set a
> unionWith :: (Ord a) => (a -> a -> a) -> set a -> set a -> set a
> delete :: (Ord a) => a -> set a -> set a
> intersect :: (Ord a) => set a -> set a -> set a
> minus :: (Ord a) => set a -> set a -> set a
> partition :: (Ord a) => (a -> Bool) -> set a -> (set a, set a)
> filter :: (Ord a) => (a -> Bool) -> set a -> set a
> unionMap :: (Ord a, Ord b) => set a -> (a -> set b) -> set b
> isEmpty :: (Ord a) => set a -> Bool
> isSingle :: (Ord a) => set a -> Bool -- isSingleton
> intersecting :: (Ord a) => set a -> set a -> Bool
> isSubsetOf :: (Ord a) => set a -> set a -> Bool
> member :: (Ord a) => a -> set a -> Bool -- elem
> fold :: (Ord a) => (a -> b -> b) -> b -> set a -> b
> fold1 :: (Ord a) => (a -> a -> a) -> set a -> a
> split :: (Ord a) => set a -> SeqView set a
> splitMin :: (Ord a) => set a -> SeqView set a
> splitMax :: (Ord a) => set a -> SeqView set a
> within :: (Ord a) => (a, a) -> set a -> [a] -- range
> size :: (Ord a) => set a -> Int
> genericSize :: (Ord a, Integral n) => set a -> n
> fromList :: (Ord a) => [a] -> set a
> toList :: (Ord a) => set a -> [a]
> fromOrderedList :: (Ord a) => [a] -> set a
> toOrderedList :: (Ord a) => set a -> [a]
> single a = add a empty
> add = addWith (\a b -> b)
> addWith f a s = unionWith f (single a) s
> union = unionWith (\a b -> b)
> unionWith f s1 s2 = fold (addWith f) s1 s2
> delete a s = filter (/= a) s
> intersect s1 s2 = filter (\a -> member a s2) s1
> minus s1 s2 = filter (\a -> not (member a s2)) s1
> partition p s = (filter p s, filter (not . p) s)
> filter p s = fold condAdd empty s
> where condAdd a s
> | p a = add a s
> | otherwise = s
> unionMap s f = fold (union . f) empty s
> isEmpty s = size s == 0
> isSingle s = size s == 1
> intersecting s1 s2 = not (isEmpty (s1 `intersect` s2))
> isSubsetOf s1 s2 = isEmpty (s1 `minus` s2)
> member a = fold (\b r -> a ==b || r) False
> fold (*) e s = case split s of
> Null -> e
> Cons a s -> a * fold (*) e s
> fold1 (*) s = case split s of
> Null -> error "fold1 of empty set"
> Cons a s -> fold (*) a s
> within (l, r) = fold condCons []
> where condCons a x
> | l <= a && a <= r = a : x
> | otherwise = x
> size = fold (\_ n -> n + 1) 0
> genericSize = fold (\_ n -> n + 1) 0
> fromList = foldr add empty
> toList = fold (:) []
> fromOrderedList = fromList -- Sortierung wird nicht
>ausgenutzt
> toOrderedList s = case splitMin s of
> Null -> []
> Cons a s -> a : toOrderedList s
> addMany :: (Set set, Ord a) => [a] -> set a -> set a
> -- addMany x s = foldr add s x -- insertion sort
> addMany x s = fromList x `union` s -- merge sort
> unionMany :: (Set set, Ord a) => [set a] -> set a
> unionMany = foldm union empty
> deleteMany :: (Set set, Ord a) => [a] -> set a -> set a
> -- deleteMany x s = foldr delete s x
> deleteMany x s = s `minus` fromList x
> intersectMany :: (Set set, Ord a) => [set a] -> set a
> intersectMany = foldm intersect empty
> class (Set set) => SubSet set where
> emptyOf :: (Ord a) => (a, a) -> set a
> complement :: (Ord a) => set a -> set a
> instance Set [] where
Construction.
> empty = []
> single a = [a]
> addWith f a [] = [a]
> addWith f a x@(b:x') = case compare a b of
> LT -> a : x
> EQ -> f b a : x'
> GT -> b : addWith f a x'
> unionWith f [] y = y
> unionWith f x@(_:_) [] = x
> unionWith f x@(a:x') y@(b:y') = case compare a b of
> LT -> a : unionWith f x' y
> EQ -> f a b : unionWith f x' y'
> GT -> b : unionWith f x y'
Modification.
> delete a [] = []
> delete a x@(b:x') = case compare a b of
> LT -> x
> EQ -> x'
> GT -> b : delete a x'
> intersect [] y = []
> intersect x@(_:_) [] = []
> intersect x@(a:x') y@(b:y') = case compare a b of
> LT -> intersect x' y
> EQ -> a : intersect x' y'
> GT -> intersect x y'
> minus [] y = []
> minus x@(_:_) [] = x
> minus x@(a:x') y@(b:y') = case compare a b of
> LT -> a : minus x' y
> EQ -> minus x' y'
> GT -> minus x y'
> filter = Prelude.filter
> unionMap s f = foldm union empty (map f s)
Testing.
> isEmpty = null
> isSingle [_] = True
> isSingle _ = False
> intersecting [] y = False
> intersecting x@(_:_) [] = False
> intersecting x@(a:x') y@(b:y') = case compare a b of
> LT -> intersecting x' y
> EQ -> True
> GT -> intersecting x y'
> isSubsetOf [] y = True
> isSubsetOf x@(_:_) [] = False
> isSubsetOf x@(a:x') y@(b:y') = case compare a b of
> LT -> False
> EQ -> isSubsetOf x' y'
> GT -> isSubsetOf x y'
> member a [] = False
> member a x@(b:x') = case compare a b of
> LT -> False
> EQ -> True
> GT -> member a x'
Extraction.
> fold = foldr
> fold1 = foldr1
> split [] = Null
> split (a:x) = Cons a x
> splitMin [] = Null
> splitMin (a:x) = Cons a x
> splitMax [] = Null
> splitMax x = Cons (last x) (init x)
> within (l, r) = takeWhile (<= r) . dropWhile (< l)
Size.
> size = length
> size = genericLength
Conversion.
> fromList = unique . sort
> toList = id
> fromOrderedList = unique
> toOrderedList = id
> foldm :: (a -> a -> a) -> a -> [a] -> a
> foldm (*) e [] = e
> foldm (*) e x = fst (f (length x) x)
> where f n x = if n==1 then (head x, tail x)
> else let m = n `div` 2
> (a, y) = f m x
> (b, z) = f (n - m) y
> in (a * b, z)
> unique :: (Eq a) => [a] -> [a]
> unique [] = []
> unique [a] = [a]
> unique (a:x@(b:_)) = if a==b then unique x else a : unique x
===============================================================================
And here is what happens:
===============================================================================
> ghc-2.02 -v -c Set.lhs
The Glorious Glasgow Haskell Compilation System, version 2.02, patchlevel 0
literate pre-processor:
echo '#line 1 "Set.lhs"' > /tmp/ghc3903.lpp &&
/home/III/a/ralf/FP/fptools/lib/sparc-sun-solaris2/ghc-2.02/unlit Set.lhs - >>
/tmp/ghc3903.lpp
real 0.0
user 0.0
sys 0.0
Ineffective C pre-processor:
echo '#line 1 "Set.lhs"' > /tmp/ghc3903.cpp && cat /tmp/ghc3903.lpp >>
/tmp/ghc3903.cpp
real 0.0
user 0.0
sys 0.0
Haskell compiler:
/home/III/a/ralf/FP/fptools/lib/sparc-sun-solaris2/ghc-2.02/hsc ,-W
,/tmp/ghc3903.cpp -hisuf-prelude=.hi -hisuf=.hi -fignore-interface-pragmas
-fomit-interface-pragmas -fsimplify \( -ffloat-lets-exposing-whnf -ffloat-primops-ok
-fcase-of-case -freuse-con -fpedantic-bottoms -fsimpl-uf-use-threshold0
-fessential-unfoldings-only -fmax-simplifier-iterations4 \)
-himap=.:/home/III/a/ralf/FP/fptools/lib/sparc-sun-solaris2/ghc-2.02/imports -v
-hifile=/tmp/ghc3903.hi -S=/tmp/ghc3903.s +RTS -H6000000 -K1000000
Glasgow Haskell Compiler, version 2.02, for Haskell 1.3
panic! (the `impossible' happened):
lookupBindC:no info!
for: ds_d2ZA
(probably: data dependencies broken by an optimisation pass)
static binds for:
Set.scsel_SubSetSetSet{-a1Hh,x-}
m.map_a1Hi
m.==_a1Hj
m.fromInt_a1Hk
lit_a1Hl
lit_a1Hn
m.+_a1Ho
ds_d2Zd
ds_d2Ze
ds_d2Zf
ds_d2Zg
ds_d2Zh
ds_d2Zi
ds_d2Zj
ds_d2Zk
ds_d2Zl
ds_d2Zm
ds_d2Zn
ds_d2Zo
ds_d2Zp
ds_d2Zq
ds_d2Zr
ds_d2Zs
ds_d2Zt
ds_d2Zu
ds_d2Zv
ds_d2Zw
ds_d2Zx
ds_d2Zy
ds_d2Zz
ds_d2ZB
ds_d2ZC
ds_d2ZD
ds_d2ZE
ds_d2ZF
ds_d42a
ds_d44f
Set.foldm{-r80,x-}
Set.unique{-r81,x-}
Set.Null{-reF,x-}
Set.Cons{-reG,x-}
Set.empty{-reH,x-}
Set.single{-reI,x-}
Set.add{-reJ,x-}
Set.addWith{-reK,x-}
Set.union{-reL,x-}
Set.unionWith{-reM,x-}
Set.delete{-reN,x-}
Set.intersect{-reO,x-}
Set.minus{-reP,x-}
Set.partition{-reQ,x-}
Set.filter{-reR,x-}
Set.unionMap{-reS,x-}
Set.isEmpty{-reT,x-}
Set.isSingle{-reU,x-}
Set.intersecting{-reV,x-}
Set.isSubsetOf{-reW,x-}
Set.member{-reX,x-}
Set.fold{-reY,x-}
Set.fold1{-reZ,x-}
Set.split{-rf0,x-}
Set.splitMin{-rf1,x-}
Set.splitMax{-rf2,x-}
Set.within{-rf3,x-}
Set.size{-rf4,x-}
Set.genericSize{-rf5,x-}
Set.fromList{-rf6,x-}
Set.toList{-rf7,x-}
Set.fromOrderedList{-rf8,x-}
Set.toOrderedList{-rf9,x-}
Set.emptyOf{-rfa,x-}
Set.complement{-rfb,x-}
Set.$mempty{-r1o5,x-}
Set.$msingle{-r1o6,x-}
Set.$madd{-r1o7,x-}
Set.$maddWith{-r1o8,x-}
Set.$munion{-r1o9,x-}
Set.$munionWith{-r1oa,x-}
Set.$mdelete{-r1ob,x-}
Set.$mintersect{-r1oc,x-}
Set.$mminus{-r1od,x-}
Set.$mpartition{-r1oe,x-}
Set.$mfilter{-r1of,x-}
Set.$munionMap{-r1og,x-}
Set.$misEmpty{-r1oh,x-}
Set.$misSingle{-r1oi,x-}
Set.$mintersecting{-r1oj,x-}
Set.$misSubsetOf{-r1ok,x-}
Set.$mmember{-r1ol,x-}
Set.$mfold{-r1om,x-}
Set.$mfold1{-r1on,x-}
Set.$msplit{-r1oo,x-}
Set.$msplitMin{-r1op,x-}
Set.$msplitMax{-r1oq,x-}
Set.$mwithin{-r1or,x-}
Set.$msize{-r1os,x-}
Set.$mgenericSize{-r1ot,x-}
Set.$mfromList{-r1ou,x-}
Set.$mtoList{-r1ov,x-}
Set.$mfromOrderedList{-r1ow,x-}
Set.$mtoOrderedList{-r1ox,x-}
Set.$memptyOf{-r1Hf,x-}
Set.$mcomplement{-r1Hg,x-}
Set.$d2{-r2Sq,x-}
Set.$d1{-r2U9,x-}
nrlit_sbmP
nrlit_sbmQ
nrlit_sbmR
nrlit_sbmS
nrlit_sbmT
nrlit_sbmU
nrlit_sbmV
local binds for:
Please report it as a compiler bug to [EMAIL PROTECTED]
real 5.7
user 4.9
sys 0.2
deleting... /tmp/ghc3903.hi /tmp/ghc3903.s
rm -f /tmp/ghc3903*
> uname -a
SunOS blei 5.5.1 Generic sun4u sparc SUNW,Ultra-1
===============================================================================
A workaround is greatly appreciated, since this file contains some very
basic stuff ...
Cheers, Ralf
