diff options
author | simonpj <unknown> | 2005-07-19 16:45:02 +0000 |
---|---|---|
committer | simonpj <unknown> | 2005-07-19 16:45:02 +0000 |
commit | a7ecdf96844404b7bc8273d4ff6d85759278427c (patch) | |
tree | bc03e6e6643d96a1237b61e9caf5f047e458e42e /ghc/compiler/utils | |
parent | 8a9aba1ff5e66aad02aba0997339ea6ec60d6b1e (diff) | |
download | haskell-a7ecdf96844404b7bc8273d4ff6d85759278427c.tar.gz |
[project @ 2005-07-19 16:44:50 by simonpj]
WARNING: this is a big commit. You might want
to wait a few days before updating, in case I've
broken something.
However, if any of the changes are what you wanted,
please check it out and test!
This commit does three main things:
1. A re-organisation of the way that GHC handles bindings in HsSyn.
This has been a bit of a mess for quite a while. The key new
types are
-- Bindings for a let or where clause
data HsLocalBinds id
= HsValBinds (HsValBinds id)
| HsIPBinds (HsIPBinds id)
| EmptyLocalBinds
-- Value bindings (not implicit parameters)
data HsValBinds id
= ValBindsIn -- Before typechecking
(LHsBinds id) [LSig id] -- Not dependency analysed
-- Recursive by default
| ValBindsOut -- After typechecking
[(RecFlag, LHsBinds id)]-- Dependency analysed
2. Implement Mark Jones's idea of increasing polymoprhism
by using type signatures to cut the strongly-connected components
of a recursive group. As a consequence, GHC no longer insists
on the contexts of the type signatures of a recursive group
being identical.
This drove a significant change: the renamer no longer does dependency
analysis. Instead, it attaches a free-variable set to each binding,
so that the type checker can do the dep anal. Reason: the typechecker
needs to do *two* analyses:
one to find the true mutually-recursive groups
(which we need so we can build the right CoreSyn)
one to find the groups in which to typecheck, taking
account of type signatures
3. Implement non-ground SPECIALISE pragmas, as promised, and as
requested by Remi and Ross. Certainly, this should fix the
current problem with GHC, namely that if you have
g :: Eq a => a -> b -> b
then you can now specialise thus
SPECIALISE g :: Int -> b -> b
(This didn't use to work.)
However, it goes further than that. For example:
f :: (Eq a, Ix b) => a -> b -> b
then you can make a partial specialisation
SPECIALISE f :: (Eq a) => a -> Int -> Int
In principle, you can specialise f to *any* type that is
"less polymorphic" (in the sense of subsumption) than f's
actual type. Such as
SPECIALISE f :: Eq a => [a] -> Int -> Int
But I haven't tested that.
I implemented this by doing the specialisation in the typechecker
and desugarer, rather than leaving around the strange SpecPragmaIds,
for the specialiser to find. Indeed, SpecPragmaIds have vanished
altogether (hooray).
Pragmas in general are handled more tidily. There's a new
data type HsBinds.Prag, which lives in an AbsBinds, and carries
pragma info from the typechecker to the desugarer.
Smaller things
- The loop in the renamer goes via RnExpr, instead of RnSource.
(That makes it more like the type checker.)
- I fixed the thing that was causing 'check_tc' warnings to be
emitted.
Diffstat (limited to 'ghc/compiler/utils')
-rw-r--r-- | ghc/compiler/utils/IOEnv.hs | 6 | ||||
-rw-r--r-- | ghc/compiler/utils/ListSetOps.lhs | 27 | ||||
-rw-r--r-- | ghc/compiler/utils/UniqFM.lhs | 16 | ||||
-rw-r--r-- | ghc/compiler/utils/Util.lhs | 5 |
4 files changed, 37 insertions, 17 deletions
diff --git a/ghc/compiler/utils/IOEnv.hs b/ghc/compiler/utils/IOEnv.hs index 6f383b2150..f937f6a27e 100644 --- a/ghc/compiler/utils/IOEnv.hs +++ b/ghc/compiler/utils/IOEnv.hs @@ -9,7 +9,7 @@ module IOEnv ( -- Standard combinators, specialised returnM, thenM, thenM_, failM, failWithM, mappM, mappM_, mapSndM, sequenceM, sequenceM_, - foldlM, + foldlM, foldrM, mapAndUnzipM, mapAndUnzip3M, checkM, ifM, zipWithM, zipWithM_, @@ -154,6 +154,7 @@ mapSndM :: (b -> IOEnv env c) -> [(a,b)] -> IOEnv env [(a,c)] sequenceM :: [IOEnv env a] -> IOEnv env [a] sequenceM_ :: [IOEnv env a] -> IOEnv env () foldlM :: (a -> b -> IOEnv env a) -> a -> [b] -> IOEnv env a +foldrM :: (b -> a -> IOEnv env a) -> a -> [b] -> IOEnv env a mapAndUnzipM :: (a -> IOEnv env (b,c)) -> [a] -> IOEnv env ([b],[c]) mapAndUnzip3M :: (a -> IOEnv env (b,c,d)) -> [a] -> IOEnv env ([b],[c],[d]) checkM :: Bool -> IOEnv env () -> IOEnv env () -- Perform arg if bool is False @@ -187,6 +188,9 @@ sequenceM_ (x:xs) = do { x; sequenceM_ xs } foldlM k z [] = return z foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs } +foldrM k z [] = return z +foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } + mapAndUnzipM f [] = return ([],[]) mapAndUnzipM f (x:xs) = do { (r,s) <- f x; (rs,ss) <- mapAndUnzipM f xs; diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs index b93a045832..02950722a2 100644 --- a/ghc/compiler/utils/ListSetOps.lhs +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -10,10 +10,10 @@ module ListSetOps ( -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C, - mkLookupFun, assocElts, + mkLookupFun, findInList, assocElts, -- Duplicate handling - hasNoDups, runs, removeDups, removeDupsEq, + hasNoDups, runs, removeDups, findDupsEq, equivClasses, equivClassesByUniq ) where @@ -24,7 +24,7 @@ import Outputable import Unique ( Unique ) import UniqFM ( eltsUFM, emptyUFM, addToUFM_C ) import Util ( isn'tIn, isIn, mapAccumR, sortLe ) -import List ( union ) +import List ( partition ) \end{code} @@ -125,6 +125,11 @@ mkLookupFun eq alist s = case [a | (s',a) <- alist, s' `eq` s] of [] -> Nothing (a:_) -> Just a + +findInList :: (a -> Bool) -> [a] -> Maybe a +findInList p [] = Nothing +findInList p (x:xs) | p x = Just x + | otherwise = findInList p xs \end{code} @@ -195,16 +200,12 @@ removeDups cmp xs collect_dups dups_so_far [x] = (dups_so_far, x) collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) -removeDupsEq :: Eq a => [a] -> ([a], [[a]]) --- Same, but with only equality --- It's worst case quadratic, but we only use it on short lists -removeDupsEq [] = ([], []) -removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs) - where - (ys,zs) = removeDupsEq (filter (/= x) xs) -removeDupsEq (x:xs) | otherwise = (x:ys, zs) - where - (ys,zs) = removeDupsEq xs +findDupsEq :: (a->a->Bool) -> [a] -> [[a]] +findDupsEq eq [] = [] +findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs + | otherwise = (x:eq_xs) : findDupsEq eq neq_xs + where + (eq_xs, neq_xs) = partition (eq x) xs \end{code} diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 52d34d9983..d2676bf1af 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -19,7 +19,7 @@ module UniqFM ( unitDirectlyUFM, listToUFM, listToUFM_Directly, - addToUFM,addToUFM_C, + addToUFM,addToUFM_C,addToUFM_Acc, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, @@ -82,6 +82,13 @@ addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result -> key -> elt -- new -> UniqFM elt -- result +addToUFM_Acc :: Uniquable key => + (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- result + addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> UniqFM elt -> [(key,elt)] -> UniqFM elt @@ -245,6 +252,11 @@ addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt addToUFM_C combiner fm key elt = insert_ele combiner fm (getKey# (getUnique key)) elt +addToUFM_Acc add unit fm key item + = insert_ele combiner fm (getKey# (getUnique key)) (unit item) + where + combiner old _unit_item = add item old + addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs @@ -659,7 +671,7 @@ and if necessary do $\lambda$ lifting on our functions that are bound. \begin{code} insert_ele - :: (a -> a -> a) + :: (a -> a -> a) -- old -> new -> result -> UniqFM a -> FastInt -> a diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index b16f6eb969..0911dba841 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -13,7 +13,7 @@ module Util ( mapAndUnzip, mapAndUnzip3, nOfThem, filterOut, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, - isSingleton, only, + isSingleton, only, singleton, notNull, snocView, isIn, isn'tIn, @@ -299,6 +299,9 @@ listLengthCmp = atLength atLen atEnd atLen [] = EQ atLen _ = GT +singleton :: a -> [a] +singleton x = [x] + isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False |