summaryrefslogtreecommitdiff
path: root/ghc/compiler/utils
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/utils')
-rw-r--r--ghc/compiler/utils/Argv.lhs29
-rw-r--r--ghc/compiler/utils/Bag.lhs22
-rw-r--r--ghc/compiler/utils/Digraph.lhs72
-rw-r--r--ghc/compiler/utils/FastString.lhs356
-rw-r--r--ghc/compiler/utils/FiniteMap.lhs124
-rw-r--r--ghc/compiler/utils/HandleHack.lhi26
-rw-r--r--ghc/compiler/utils/ListSetOps.lhs9
-rw-r--r--ghc/compiler/utils/MatchEnv.lhs116
-rw-r--r--ghc/compiler/utils/Maybes.lhs20
-rw-r--r--ghc/compiler/utils/Outputable.lhs316
-rw-r--r--ghc/compiler/utils/Pretty.lhs14
-rw-r--r--ghc/compiler/utils/PrimPacked.lhs224
-rw-r--r--ghc/compiler/utils/SST.lhs152
-rw-r--r--ghc/compiler/utils/SpecLoop.lhi62
-rw-r--r--ghc/compiler/utils/StringBuffer.lhs53
-rw-r--r--ghc/compiler/utils/Ubiq.hs10
-rw-r--r--ghc/compiler/utils/Ubiq.lhi152
-rw-r--r--ghc/compiler/utils/UniqFM.lhs18
-rw-r--r--ghc/compiler/utils/UniqSet.lhs14
-rw-r--r--ghc/compiler/utils/Util.lhs171
20 files changed, 714 insertions, 1246 deletions
diff --git a/ghc/compiler/utils/Argv.lhs b/ghc/compiler/utils/Argv.lhs
index c9fc6a589b..4793b127dc 100644
--- a/ghc/compiler/utils/Argv.lhs
+++ b/ghc/compiler/utils/Argv.lhs
@@ -4,36 +4,19 @@
\section[Argv]{@Argv@: direct (non-standard) access to command-line arguments}
\begin{code}
-#include "HsVersions.h"
-
module Argv ( argv ) where
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
-import PreludeGlaST ( indexAddrOffAddr )
-#endif
+#include "HsVersions.h"
-CHK_Ubiq() -- debugging consistency check
-IMP_FASTSTRING()
+import FastString
-#if __GLASGOW_HASKELL__ == 201
-# define ADDR GHCbase.Addr
-# define PACK_STR packCString
-#elif __GLASGOW_HASKELL__ >= 202
-# define ADDR GlaExts.Addr
-# define PACK_STR mkFastCharString
-#else
-# define ADDR _Addr
-# define PACK_STR mkFastCharString
-/*
-# define ADDR _Addr
-# define PACK_STR _packCString
-*/
-#endif
+import GlaExts ( Addr )
+import ArrBase ( indexAddrOffAddr )
argv :: [FAST_STRING]
argv = unpackArgv ``prog_argv'' (``prog_argc''::Int)
-unpackArgv :: ADDR -> Int -> [FAST_STRING] -- argv[1 .. argc-1]
+unpackArgv :: Addr -> Int -> [FAST_STRING] -- argv[1 .. argc-1]
unpackArgv argv argc = unpack 1
where
@@ -42,6 +25,6 @@ unpackArgv argv argc = unpack 1
= if (n >= argc)
then ([] :: [FAST_STRING])
else case (indexAddrOffAddr argv n) of { item ->
- PACK_STR item : unpack (n + 1)
+ mkFastCharString item : unpack (n + 1)
}
\end{code}
diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs
index fcb9a9c40b..546ad2fbc3 100644
--- a/ghc/compiler/utils/Bag.lhs
+++ b/ghc/compiler/utils/Bag.lhs
@@ -4,8 +4,6 @@
\section[Bags]{@Bag@: an unordered collection with duplicates}
\begin{code}
-#include "HsVersions.h"
-
module Bag (
Bag, -- abstract type
@@ -17,12 +15,14 @@ module Bag (
listToBag, bagToList
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
+#include "HsVersions.h"
+
+import Outputable
+import List ( partition )
+\end{code}
-import Outputable --( interpp'SP )
-import Pretty
+\begin{code}
data Bag a
= EmptyBag
| UnitBag a
@@ -149,10 +149,10 @@ bagToList b = foldrBag (:) [] b
\begin{code}
instance (Outputable a) => Outputable (Bag a) where
- ppr sty EmptyBag = ptext SLIT("emptyBag")
- ppr sty (UnitBag a) = ppr sty a
- ppr sty (TwoBags b1 b2) = hsep [ppr sty b1 <> comma, ppr sty b2]
- ppr sty (ListBag as) = interpp'SP sty as
- ppr sty (ListOfBags bs) = brackets (interpp'SP sty bs)
+ ppr EmptyBag = ptext SLIT("emptyBag")
+ ppr (UnitBag a) = ppr a
+ ppr (TwoBags b1 b2) = hsep [ppr b1 <> comma, ppr b2]
+ ppr (ListBag as) = interpp'SP as
+ ppr (ListOfBags bs) = brackets (interpp'SP bs)
\end{code}
diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs
index 3c69ce29e9..15df0baa14 100644
--- a/ghc/compiler/utils/Digraph.lhs
+++ b/ghc/compiler/utils/Digraph.lhs
@@ -1,15 +1,13 @@
\begin{code}
-# include "HsVersions.h"
-
module Digraph(
-- At present the only one with a "nice" external interface
stronglyConnComp, stronglyConnCompR, SCC(..),
- SYN_IE(Graph), SYN_IE(Vertex),
+ Graph, Vertex,
graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree,
- Tree(..), SYN_IE(Forest),
+ Tree(..), Forest,
showTree, showForest,
dfs, dff,
@@ -22,6 +20,8 @@ module Digraph(
) where
+# include "HsVersions.h"
+
------------------------------------------------------------------------------
-- A version of the graph algorithms described in:
--
@@ -31,7 +31,6 @@ module Digraph(
-- Also included is some additional code for printing tree structures ...
------------------------------------------------------------------------------
-#ifdef REALLY_HASKELL_1_3
#define ARR_ELT (COMMA)
@@ -40,26 +39,7 @@ import List
import ST
import ArrBase
import Maybe
-
-# if __GLASGOW_HASKELL__ >= 209
-import GlaExts ( thenST, returnST )
-# endif
-
-#else
-
-#define ARR_ELT (:=)
-#define runST _runST
-#define MutableArray _MutableArray
-#define Show Text
-
-import PreludeGlaST
-import Maybes ( mapMaybe )
-
-#endif
-
-import Util ( Ord3(..),
- sortLt
- )
+import Util ( sortLt )
\end{code}
@@ -74,7 +54,7 @@ data SCC vertex = AcyclicSCC vertex
| CyclicSCC [vertex]
stronglyConnComp
- :: Ord3 key
+ :: Ord key
=> [(node, key, [key])] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
@@ -89,7 +69,7 @@ stronglyConnComp edges
-- The "R" interface is used when you expect to apply SCC to
-- the (some of) the result of SCC, so you dont want to lose the dependency info
stronglyConnCompR
- :: Ord3 key
+ :: Ord key
=> [(node, key, [key])] -- The graph; its ok for the
-- out-list to contain keys which arent
-- a vertex key, they are ignored
@@ -132,13 +112,13 @@ edges :: Graph -> [Edge]
edges g = [ (v, w) | v <- vertices g, w <- g!v ]
mapT :: (Vertex -> a -> b) -> Table a -> Table b
-mapT f t = array (bounds t) [ ARR_ELT v (f v (t!v)) | v <- indices t ]
+mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
buildG :: Bounds -> [Edge] -> Graph
#ifdef REALLY_HASKELL_1_3
buildG bounds edges = accumArray (flip (:)) [] bounds edges
#else
-buildG bounds edges = accumArray (flip (:)) [] bounds [ARR_ELT k v | (k,v) <- edges]
+buildG bounds edges = accumArray (flip (:)) [] bounds [(,) k v | (k,v) <- edges]
#endif
transposeG :: Graph -> Graph
@@ -158,7 +138,7 @@ indegree = outdegree . transposeG
\begin{code}
graphFromEdges
- :: Ord3 key
+ :: Ord key
=> [(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]))
graphFromEdges edges
@@ -167,13 +147,13 @@ graphFromEdges edges
max_v = length edges - 1
bounds = (0,max_v) :: (Vertex, Vertex)
sorted_edges = sortLt lt edges
- edges1 = zipWith ARR_ELT [0..] sorted_edges
+ edges1 = zipWith (,) [0..] sorted_edges
- graph = array bounds [ARR_ELT v (mapMaybe key_vertex ks) | ARR_ELT v (_, _, ks) <- edges1]
- key_map = array bounds [ARR_ELT v k | ARR_ELT v (_, k, _ ) <- edges1]
+ graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
+ key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
vertex_map = array bounds edges1
- (_,k1,_) `lt` (_,k2,_) = case k1 `cmp` k2 of { LT_ -> True; other -> False }
+ (_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False }
-- key_vertex :: key -> Maybe Vertex
-- returns Nothing for non-interesting vertices
@@ -181,10 +161,10 @@ graphFromEdges edges
where
find a b | a > b
= Nothing
- find a b = case cmp k (key_map ! mid) of
- LT_ -> find a (mid-1)
- EQ_ -> Just mid
- GT_ -> find (mid+1) b
+ find a b = case compare k (key_map ! mid) of
+ LT -> find a (mid-1)
+ EQ -> Just mid
+ GT -> find (mid+1) b
where
mid = (a + b) `div` 2
\end{code}
@@ -264,20 +244,20 @@ generate :: Graph -> Vertex -> Tree Vertex
generate g v = Node v (map (generate g) (g!v))
prune :: Bounds -> Forest Vertex -> Forest Vertex
-prune bnds ts = runST (mkEmpty bnds `thenST` \m ->
+prune bnds ts = runST (mkEmpty bnds >>= \m ->
chop m ts)
chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
-chop m [] = returnST []
+chop m [] = return []
chop m (Node v ts : us)
- = contains m v `thenStrictlyST` \visited ->
+ = contains m v >>= \visited ->
if visited then
chop m us
else
- include m v `thenStrictlyST` \_ ->
- chop m ts `thenStrictlyST` \as ->
- chop m us `thenStrictlyST` \bs ->
- returnST (Node v as : bs)
+ include m v >>= \_ ->
+ chop m ts >>= \as ->
+ chop m us >>= \bs ->
+ return (Node v as : bs)
\end{code}
@@ -302,7 +282,7 @@ preOrd :: Graph -> [Vertex]
preOrd = preorderF . dff
tabulate :: Bounds -> [Vertex] -> Table Int
-tabulate bnds vs = array bnds (zipWith ARR_ELT vs [1..])
+tabulate bnds vs = array bnds (zipWith (,) vs [1..])
preArr :: Bounds -> Forest Vertex -> Table Int
preArr bnds = tabulate bnds . preorderF
diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index e9624be6d9..0d6b055214 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -7,24 +7,27 @@ Compact representations of character strings with
unique identifiers (hash-cons'ish).
\begin{code}
-#include "HsVersions.h"
-
module FastString
(
FastString(..), -- not abstract, for now.
--names?
mkFastString, -- :: String -> FastString
- mkFastCharString, -- :: _Addr -> FastString
- mkFastCharString2, -- :: _Addr -> Int -> FastString
- mkFastSubString, -- :: _Addr -> Int -> Int -> FastString
+ mkFastSubString, -- :: Addr -> Int -> Int -> FastString
mkFastSubStringFO, -- :: ForeignObj -> Int -> Int -> FastString
+ -- These ones hold on to the Addr after they return, and aren't hashed;
+ -- they are used for literals
+ mkFastCharString, -- :: Addr -> FastString
+ mkFastCharString#, -- :: Addr# -> FastString
+ mkFastCharString2, -- :: Addr -> Int -> FastString
+
mkFastString#, -- :: Addr# -> Int# -> FastString
mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
mkFastSubString#, -- :: Addr# -> Int# -> Int# -> FastString
mkFastSubStringFO#, -- :: ForeignObj# -> Int# -> Int# -> FastString
+ uniqueOfFS, -- :: FastString -> Int#
lengthFS, -- :: FastString -> Int
nullFastString, -- :: FastString -> Bool
@@ -37,43 +40,32 @@ module FastString
concatFS, -- :: [FastString] -> FastString
consFS, -- :: Char -> FastString -> FastString
- hPutFS, -- :: Handle -> FastString -> IO ()
- tagCmpFS -- :: FastString -> FastString -> _CMP_TAG
+ hPutFS -- :: Handle -> FastString -> IO ()
) where
-#if __GLASGOW_HASKELL__ <= 201
-import PreludeGlaST
-import PreludeGlaMisc
-import HandleHack
-import Ubiq
-#else
-import GlaExts
-import Foreign
-import IOBase
-import IOHandle
-import ST
-import STBase
-import {-# SOURCE #-} Unique ( mkUniqueGrimily, Unique, Uniquable(..) )
-#if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char (..) )
-#endif
-#if __GLASGOW_HASKELL__ >= 206
-import PackBase
-#endif
-#if __GLASGOW_HASKELL__ >= 209
-import Addr
-import IOExts
-# define newVar newIORef
-# define readVar readIORef
-# define writeVar writeIORef
-#endif
-
-#endif
+-- This #define suppresses the "import FastString" that
+-- HsVersions otherwise produces
+#define COMPILING_FAST_STRING
+#include "HsVersions.h"
+import PackBase
import PrimPacked
+import GlaExts
+import Addr ( Addr(..) )
+import STBase ( StateAndPtr#(..) )
+import ArrBase ( MutableArray(..) )
+import Foreign ( ForeignObj(..) )
+import IOExts ( IOArray(..), newIOArray,
+ IORef, newIORef, readIORef, writeIORef
+ )
+import IO
+import IOHandle ( filePtr, readHandle, writeHandle )
+import IOBase ( Handle__(..), IOError(..), IOErrorType(..),
+ IOResult(..), IO(..),
+ constructError
+ )
#define hASH_TBL_SIZE 993
-
\end{code}
@FastString@s are packed representations of strings
@@ -96,32 +88,19 @@ data FastString
Int# -- length (cached)
instance Eq FastString where
- a == b = case tagCmpFS a b of { _LT -> False; _EQ -> True; _GT -> False }
- a /= b = case tagCmpFS a b of { _LT -> True; _EQ -> False; _GT -> True }
-
-{-
- (FastString u1# _ _) == (FastString u2# _ _) = u1# ==# u2#
--}
-
-instance Uniquable FastString where
- uniqueOf (FastString u# _ _) = mkUniqueGrimily u#
- uniqueOf (CharStr a# l#) =
- {-
- [A somewhat moby hack]: to avoid entering all sorts
- of junk into the hash table, all C char strings
- are by default left out. The benefit of being in
- the table is that string comparisons are lightning fast,
- just an Int# comparison.
-
- But, if you want to get the Unique of a CharStr, we
- enter it into the table and return that unique. This
- works, but causes the CharStr to be looked up in the hash
- table each time it is accessed..
- -}
- mkUniqueGrimily (case mkFastString# a# l# of { FastString u# _ _ -> u#}) -- Ugh!
+ a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
+ a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
-instance Uniquable Int where
- uniqueOf (I# i#) = mkUniqueGrimily i#
+instance Ord FastString where
+ a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
+ a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
+ a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
+ max x y | x >= y = x
+ | otherwise = y
+ min x y | x <= y = x
+ | otherwise = y
+ compare a b = cmpFS a b
instance Text FastString where
showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
@@ -130,8 +109,8 @@ instance Text FastString where
getByteArray# :: FastString -> ByteArray#
getByteArray# (FastString _ _ ba#) = ba#
-getByteArray :: FastString -> _ByteArray Int
-getByteArray (FastString _ l# ba#) = _ByteArray (0,I# l#) ba#
+getByteArray :: FastString -> ByteArray Int
+getByteArray (FastString _ l# ba#) = ByteArray (0,I# l#) ba#
lengthFS :: FastString -> Int
lengthFS (FastString _ l# _) = I# l#
@@ -142,11 +121,7 @@ nullFastString (FastString _ l# _) = l# ==# 0#
nullFastString (CharStr _ l#) = l# ==# 0#
unpackFS :: FastString -> String
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
-unpackFS (FastString _ l# ba#) = byteArrayToString (_ByteArray (0,I# l#) ba#)
-#else
unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l#
-#endif
unpackFS (CharStr addr len#) =
unpack 0#
where
@@ -174,6 +149,21 @@ tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
consFS :: Char -> FastString -> FastString
consFS c fs = mkFastString (c:unpackFS fs)
+uniqueOfFS :: FastString -> Int#
+uniqueOfFS (FastString u# _ _) = u#
+uniqueOfFS (CharStr a# l#) = case mkFastString# a# l# of { FastString u# _ _ -> u#} -- Ugh!
+ {-
+ [A somewhat moby hack]: to avoid entering all sorts
+ of junk into the hash table, all C char strings
+ are by default left out. The benefit of being in
+ the table is that string comparisons are lightning fast,
+ just an Int# comparison.
+
+ But, if you want to get the Unique of a CharStr, we
+ enter it into the table and return that unique. This
+ works, but causes the CharStr to be looked up in the hash
+ table each time it is accessed..
+ -}
\end{code}
Internally, the compiler will maintain a fast string symbol
@@ -185,54 +175,46 @@ new @FastString@s then covertly does a lookup, re-using the
data FastStringTable =
FastStringTable
Int#
- (MutableArray# _RealWorld [FastString])
+ (MutableArray# RealWorld [FastString])
-#if __GLASGOW_HASKELL__ < 209
-type FastStringTableVar = MutableVar _RealWorld FastStringTable
-#else
type FastStringTableVar = IORef FastStringTable
-#endif
string_table :: FastStringTableVar
string_table =
- unsafePerformPrimIO (
- ST_TO_PrimIO (newArray (0::Int,hASH_TBL_SIZE) []) `thenPrimIO` \ (_MutableArray _ arr#) ->
- newVar (FastStringTable 0# arr#))
+ unsafePerformIO (
+ stToIO (newArray (0::Int,hASH_TBL_SIZE) []) >>= \ (MutableArray _ arr#) ->
+ newIORef (FastStringTable 0# arr#))
-lookupTbl :: FastStringTable -> Int# -> PrimIO [FastString]
+lookupTbl :: FastStringTable -> Int# -> IO [FastString]
lookupTbl (FastStringTable _ arr#) i# =
- ST_TO_PrimIO (
- MkST ( \ STATE_TOK(s#) ->
+ IO ( \ s# ->
case readArray# arr# i# s# of { StateAndPtr# s2# r ->
- ST_RET(r, STATE_TOK(s2#)) }))
+ IOok s2# r })
-updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> PrimIO ()
-updTbl ref (FastStringTable uid# arr#) i# ls =
- ST_TO_PrimIO (
- MkST ( \ STATE_TOK(s#) ->
- case writeArray# arr# i# ls s# of { s2# ->
- ST_RET((), STATE_TOK(s2#)) })) `thenPrimIO` \ _ ->
- writeVar ref (FastStringTable (uid# +# 1#) arr#)
+updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
+updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
+ IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> IOok s2# () }) >>
+ writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
mkFastString# :: Addr# -> Int# -> FastString
mkFastString# a# len# =
- unsafePerformPrimIO (
- readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+ unsafePerformIO (
+ readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashStr a# len#
in
-- _trace ("hashed: "++show (I# h)) $
- lookupTbl ft h `thenPrimIO` \ lookup_result ->
+ lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket" $
case copyPrefixStr (A# a#) (I# len#) of
- (_ByteArray _ barr#) ->
+ (ByteArray _ barr#) ->
let f_str = FastString uid# len# barr# in
- updTbl string_table ft h [f_str] `seqPrimIO`
- ({- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
+ updTbl string_table ft h [f_str] >>
+ ({- _trace ("new: " ++ show f_str) $ -} return f_str)
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
@@ -240,11 +222,11 @@ mkFastString# a# len# =
case bucket_match ls len# a# of
Nothing ->
case copyPrefixStr (A# a#) (I# len#) of
- (_ByteArray _ barr#) ->
+ (ByteArray _ barr#) ->
let f_str = FastString uid# len# barr# in
- updTbl string_table ft h (f_str:ls) `seqPrimIO`
- ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
- Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
+ updTbl string_table ft h (f_str:ls) >>
+ ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
+ Just v -> {- _trace ("re-use: "++show v) $ -} return v)
where
bucket_match [] _ _ = Nothing
bucket_match (v@(FastString _ l# ba#):ls) len# a# =
@@ -258,32 +240,32 @@ mkFastSubString# a# start# len# = mkFastCharString2 (A# (addrOffset# a# start#))
mkFastSubStringFO# :: ForeignObj# -> Int# -> Int# -> FastString
mkFastSubStringFO# fo# start# len# =
- unsafePerformPrimIO (
- readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+ unsafePerformIO (
+ readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashSubStrFO fo# start# len#
in
- lookupTbl ft h `thenPrimIO` \ lookup_result ->
+ lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
- (_ByteArray _ barr#) ->
+ (ByteArray _ barr#) ->
let f_str = FastString uid# len# barr# in
- updTbl string_table ft h [f_str] `seqPrimIO`
- returnPrimIO f_str
+ updTbl string_table ft h [f_str] >>
+ return f_str
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
case bucket_match ls start# len# fo# of
Nothing ->
case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
- (_ByteArray _ barr#) ->
+ (ByteArray _ barr#) ->
let f_str = FastString uid# len# barr# in
- updTbl string_table ft h (f_str:ls) `seqPrimIO`
- ( {- _trace ("new: " ++ show f_str) $ -} returnPrimIO f_str)
- Just v -> {- _trace ("re-use: "++show v) $ -} returnPrimIO v)
+ updTbl string_table ft h (f_str:ls) >>
+ ( {- _trace ("new: " ++ show f_str) $ -} return f_str)
+ Just v -> {- _trace ("re-use: "++show v) $ -} return v)
where
bucket_match [] _ _ _ = Nothing
bucket_match (v@(FastString _ l# barr#):ls) start# len# fo# =
@@ -295,39 +277,39 @@ mkFastSubStringFO# fo# start# len# =
mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
mkFastSubStringBA# barr# start# len# =
- unsafePerformPrimIO (
- readVar string_table `thenPrimIO` \ ft@(FastStringTable uid# tbl#) ->
+ unsafePerformIO (
+ readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashSubStrBA barr# start# len#
in
-- _trace ("hashed(b): "++show (I# h)) $
- lookupTbl ft h `thenPrimIO` \ lookup_result ->
+ lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket(b)" $
- case copySubStrBA (_ByteArray btm barr#) (I# start#) (I# len#) of
- (_ByteArray _ ba#) ->
+ case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
+ (ByteArray _ ba#) ->
let f_str = FastString uid# len# ba# in
- updTbl string_table ft h [f_str] `seqPrimIO`
+ updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
- returnPrimIO f_str
+ return f_str
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls start# len# barr# of
Nothing ->
- case copySubStrBA (_ByteArray (error "") barr#) (I# start#) (I# len#) of
- (_ByteArray _ ba#) ->
+ case copySubStrBA (ByteArray (error "") barr#) (I# start#) (I# len#) of
+ (ByteArray _ ba#) ->
let f_str = FastString uid# len# ba# in
- updTbl string_table ft h (f_str:ls) `seqPrimIO`
+ updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
- returnPrimIO f_str
+ return f_str
Just v ->
-- _trace ("re-use(b): "++show v) $
- returnPrimIO v
+ return v
)
where
btm = error ""
@@ -341,33 +323,32 @@ mkFastSubStringBA# barr# start# len# =
else
bucket_match ls start# len# ba#
-mkFastCharString :: _Addr -> FastString
+mkFastCharString :: Addr -> FastString
mkFastCharString a@(A# a#) =
case strLength a of{ (I# len#) -> CharStr a# len# }
-mkFastCharString2 :: _Addr -> Int -> FastString
+mkFastCharString# :: Addr# -> FastString
+mkFastCharString# a# =
+ case strLength (A# a#) of { (I# len#) -> CharStr a# len# }
+
+mkFastCharString2 :: Addr -> Int -> FastString
mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len#
mkFastString :: String -> FastString
mkFastString str =
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
- case stringToByteArray str of
-#else
case packString str of
-#endif
- (_ByteArray (_,I# len#) frozen#) ->
+ (ByteArray (_,I# len#) frozen#) ->
mkFastSubStringBA# frozen# 0# len#
{- 0-indexed array, len# == index to one beyond end of string,
i.e., (0,1) => empty string. -}
-mkFastSubString :: _Addr -> Int -> Int -> FastString
+mkFastSubString :: Addr -> Int -> Int -> FastString
mkFastSubString (A# a#) (I# start#) (I# len#) =
mkFastString# (addrOffset# a# start#) len#
mkFastSubStringFO :: _ForeignObj -> Int -> Int -> FastString
mkFastSubStringFO (_ForeignObj fo#) (I# start#) (I# len#) =
mkFastSubStringFO# fo# start# len#
-
\end{code}
\begin{code}
@@ -424,58 +405,47 @@ hashSubStrBA ba# start# len# =
\end{code}
\begin{code}
-tagCmpFS :: FastString -> FastString -> _CMP_TAG
-tagCmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
+cmpFS :: FastString -> FastString -> Ordering
+cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
if u1# ==# u2# then
- _EQ
+ EQ
else
- unsafePerformPrimIO (
- _ccall_ strcmp (_ByteArray bottom b1#) (_ByteArray bottom b2#) `thenPrimIO` \ (I# res) ->
- returnPrimIO (
- if res <# 0# then _LT
- else if res ==# 0# then _EQ
- else _GT
+ unsafePerformIO (
+ _ccall_ strcmp (ByteArray bottom b1#) (ByteArray bottom b2#) >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
))
where
bottom :: (Int,Int)
bottom = error "tagCmp"
-tagCmpFS (CharStr bs1 len1) (CharStr bs2 len2)
- = unsafePerformPrimIO (
- _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) ->
- returnPrimIO (
- if res <# 0# then _LT
- else if res ==# 0# then _EQ
- else _GT
+cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
+ = unsafePerformIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
))
where
ba1 = A# bs1
ba2 = A# bs2
-tagCmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
- = unsafePerformPrimIO (
- _ccall_ strcmp ba1 ba2 `thenPrimIO` \ (I# res) ->
- returnPrimIO (
- if res <# 0# then _LT
- else if res ==# 0# then _EQ
- else _GT
+cmpFS (FastString _ len1 bs1) (CharStr bs2 len2)
+ = unsafePerformIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
))
where
- ba1 = _ByteArray ((error "")::(Int,Int)) bs1
+ ba1 = ByteArray ((error "")::(Int,Int)) bs1
ba2 = A# bs2
-tagCmpFS a@(CharStr _ _) b@(FastString _ _ _)
+cmpFS a@(CharStr _ _) b@(FastString _ _ _)
= -- try them the other way 'round
- case (tagCmpFS b a) of { _LT -> _GT; _EQ -> _EQ; _GT -> _LT }
-
-instance Ord FastString where
- a <= b = case tagCmpFS a b of { _LT -> True; _EQ -> True; _GT -> False }
- a < b = case tagCmpFS a b of { _LT -> True; _EQ -> False; _GT -> False }
- a >= b = case tagCmpFS a b of { _LT -> False; _EQ -> True; _GT -> True }
- a > b = case tagCmpFS a b of { _LT -> False; _EQ -> False; _GT -> True }
- max x y | x >= y = x
- | otherwise = y
- min x y | x <= y = x
- | otherwise = y
- _tagCmp a b = tagCmpFS a b
+ case (cmpFS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
\end{code}
@@ -483,16 +453,6 @@ Outputting @FastString@s is quick, just block copying the chunk (using
@fwrite@).
\begin{code}
-#if __GLASGOW_HASKELL__ >= 201
-#define _ErrorHandle IOBase.ErrorHandle
-#define _ReadHandle IOBase.ReadHandle
-#define _ClosedHandle IOBase.ClosedHandle
-#define _SemiClosedHandle IOBase.SemiClosedHandle
-#define _constructError IOBase.constructError
-#define _filePtr IOHandle.filePtr
-#define failWith fail
-#endif
-
hPutFS :: Handle -> FastString -> IO ()
hPutFS handle (FastString _ l# ba#) =
if l# ==# 0# then
@@ -500,54 +460,54 @@ hPutFS handle (FastString _ l# ba#) =
else
_readHandle handle >>= \ htype ->
case htype of
- _ErrorHandle ioError ->
+ ErrorHandle ioError ->
_writeHandle handle htype >>
- failWith ioError
- _ClosedHandle ->
+ fail ioError
+ ClosedHandle ->
_writeHandle handle htype >>
- failWith MkIOError(handle,IllegalOperation,"handle is closed")
- _SemiClosedHandle _ _ ->
+ fail MkIOError(handle,IllegalOperation,"handle is closed")
+ SemiClosedHandle _ _ ->
_writeHandle handle htype >>
- failWith MkIOError(handle,IllegalOperation,"handle is closed")
- _ReadHandle _ _ _ ->
+ fail MkIOError(handle,IllegalOperation,"handle is closed")
+ ReadHandle _ _ _ ->
_writeHandle handle htype >>
- failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
+ fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
other ->
- let fp = _filePtr htype in
+ let fp = filePtr htype in
-- here we go..
- _ccall_ writeFile (_ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) `CCALL_THEN` \rc ->
+ _ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
if rc==0 then
return ()
else
- _constructError "hPutFS" `CCALL_THEN` \ err ->
- failWith err
+ constructError "hPutFS" >>= \ err ->
+ fail err
hPutFS handle (CharStr a# l#) =
if l# ==# 0# then
return ()
else
_readHandle handle >>= \ htype ->
case htype of
- _ErrorHandle ioError ->
+ ErrorHandle ioError ->
_writeHandle handle htype >>
- failWith ioError
- _ClosedHandle ->
+ fail ioError
+ ClosedHandle ->
_writeHandle handle htype >>
- failWith MkIOError(handle,IllegalOperation,"handle is closed")
- _SemiClosedHandle _ _ ->
+ fail MkIOError(handle,IllegalOperation,"handle is closed")
+ SemiClosedHandle _ _ ->
_writeHandle handle htype >>
- failWith MkIOError(handle,IllegalOperation,"handle is closed")
- _ReadHandle _ _ _ ->
+ fail MkIOError(handle,IllegalOperation,"handle is closed")
+ ReadHandle _ _ _ ->
_writeHandle handle htype >>
- failWith MkIOError(handle,IllegalOperation,"handle is not open for writing")
+ fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
other ->
- let fp = _filePtr htype in
+ let fp = filePtr htype in
-- here we go..
- _ccall_ writeFile (A# a#) fp (I# l#) `CCALL_THEN` \rc ->
+ _ccall_ writeFile (A# a#) fp (I# l#) >>= \rc ->
if rc==0 then
return ()
else
- _constructError "hPutFS" `CCALL_THEN` \ err ->
- failWith err
+ constructError "hPutFS" >>= \ err ->
+ fail err
--ToDo: avoid silly code duplic.
\end{code}
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 09e63592e2..432d4f2cf9 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -18,14 +18,6 @@ The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
near the end.
\begin{code}
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-
-#if defined(DEBUG_FINITEMAPS)/* NB NB NB */
-#define OUTPUTABLE_key , Outputable key
-#else
-#define OUTPUTABLE_key {--}
-#endif
module FiniteMap (
FiniteMap, -- abstract type
@@ -53,27 +45,26 @@ module FiniteMap (
fmToList, keysFM, eltsFM
, bagToFM
- , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet
+ , FiniteSet, emptySet, mkSet, isEmptySet
, elementOf, setToList, union, minusSet
) where
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(SpecLoop)
+#include "HsVersions.h"
+#define IF_NOT_GHC(a) {--}
+
+#if defined(DEBUG_FINITEMAPS)/* NB NB NB */
+#define OUTPUTABLE_key , Outputable key
#else
-import {-# SOURCE #-} Name
+#define OUTPUTABLE_key {--}
#endif
-#if __GLASGOW_HASKELL__ >= 202
+import {-# SOURCE #-} Name
import GlaExts
-#endif
-#if defined(USE_FAST_STRINGS)
import FastString
-#endif
import Maybes
import Bag ( Bag, foldrBag )
-import Outputable ( PprStyle, Outputable(..) )
-import Pretty ( Doc )
+import Outputable
#if ! OMIT_NATIVE_CODEGEN
# define IF_NCG(a) a
@@ -223,16 +214,10 @@ addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
addToFM_C combiner EmptyFM key elt = unitFM key elt
addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp new_key key of
- _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
-#else
- | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r
-#endif
+ = case compare new_key key of
+ LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
+ GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
+ EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
@@ -245,21 +230,10 @@ addListToFM_C combiner fm key_elt_pairs
\begin{code}
delFromFM EmptyFM del_key = emptyFM
delFromFM (Branch key elt size fm_l fm_r) del_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp del_key key of
- _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
- _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
- _EQ -> glueBal fm_l fm_r
-#else
- | del_key > key
- = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
-
- | del_key < key
- = mkBalBranch key elt (delFromFM fm_l del_key) fm_r
-
- | key == del_key
- = glueBal fm_l fm_r
-#endif
+ = case compare del_key key of
+ GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
+ LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
+ EQ -> glueBal fm_l fm_r
delListFromFM fm keys = foldl delFromFM fm keys
\end{code}
@@ -365,16 +339,10 @@ isEmptyFM fm = sizeFM fm == 0
lookupFM EmptyFM key = Nothing
lookupFM (Branch key elt _ fm_l fm_r) key_to_find
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp key_to_find key of
- _LT -> lookupFM fm_l key_to_find
- _GT -> lookupFM fm_r key_to_find
- _EQ -> Just elt
-#else
- | key_to_find < key = lookupFM fm_l key_to_find
- | key_to_find > key = lookupFM fm_r key_to_find
- | otherwise = Just elt
-#endif
+ = case compare key_to_find key of
+ LT -> lookupFM fm_l key_to_find
+ GT -> lookupFM fm_r key_to_find
+ EQ -> Just elt
key `elemFM` fm
= case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
@@ -427,10 +395,10 @@ mkBranch which key elt fm_l fm_r
= --ASSERT( left_ok && right_ok && balance_ok )
#if defined(DEBUG_FINITEMAPS)
if not ( left_ok && right_ok && balance_ok ) then
- pprPanic ("mkBranch:"++show which) (vcat [ppr PprDebug [left_ok, right_ok, balance_ok],
- ppr PprDebug key,
- ppr PprDebug fm_l,
- ppr PprDebug fm_r])
+ pprPanic ("mkBranch:"++show which) (vcat [ppr [left_ok, right_ok, balance_ok],
+ ppr key,
+ ppr fm_l,
+ ppr fm_r])
else
#endif
let
@@ -439,7 +407,7 @@ mkBranch which key elt fm_l fm_r
-- if sizeFM result <= 8 then
result
-- else
--- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
+-- pprTrace ("mkBranch:"++(show which)) (ppr result) (
-- result
-- )
where
@@ -639,29 +607,17 @@ splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Fini
splitLT EmptyFM split_key = emptyFM
splitLT (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _LT -> splitLT fm_l split_key
- _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- _EQ -> fm_l
-#else
- | split_key < key = splitLT fm_l split_key
- | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- | otherwise = fm_l
-#endif
+ = case compare split_key key of
+ LT -> splitLT fm_l split_key
+ GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
+ EQ -> fm_l
splitGT EmptyFM split_key = emptyFM
splitGT (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _GT -> splitGT fm_r split_key
- _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- _EQ -> fm_r
-#else
- | split_key > key = splitGT fm_r split_key
- | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- | otherwise = fm_r
-#endif
+ = case compare split_key key of
+ GT -> splitGT fm_r split_key
+ LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
+ EQ -> fm_r
findMin :: FiniteMap key elt -> (key,elt)
findMin (Branch key elt _ EmptyFM _) = (key,elt)
@@ -690,13 +646,13 @@ deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax
#if defined(DEBUG_FINITEMAPS)
instance (Outputable key) => Outputable (FiniteMap key elt) where
- ppr sty fm = pprX sty fm
+ ppr fm = pprX fm
-pprX sty EmptyFM = char '!'
-pprX sty (Branch key elt sz fm_l fm_r)
- = parens (hcat [pprX sty fm_l, space,
- ppr sty key, space, int (IF_GHC(I# sz, sz)), space,
- pprX sty fm_r])
+pprX EmptyFM = char '!'
+pprX (Branch key elt sz fm_l fm_r)
+ = parens (hcat [pprX fm_l, space,
+ ppr key, space, int (IF_GHC(I# sz, sz)), space,
+ pprX fm_r])
#endif
#if 0
diff --git a/ghc/compiler/utils/HandleHack.lhi b/ghc/compiler/utils/HandleHack.lhi
deleted file mode 100644
index d0fad80e42..0000000000
--- a/ghc/compiler/utils/HandleHack.lhi
+++ /dev/null
@@ -1,26 +0,0 @@
-
-The implementation of FastString output need to get at the representation
-to Handles to do a Good Job. Prelude modules in 0.29 does not export
-the Handle repr., this little hack fixes this :-)
-
-Also added mkUniqueGrimily to avoid bootstrap trouble
-
-\begin{code}
-interface HandleHack where
-
-import PreludeStdIO (Handle(..), _Handle(..), _filePtr,_readHandle, _writeHandle, BufferMode, Maybe)
-import PreludeIOError (_constructError,IOError13(..))
-import PreludeGlaST (_MutableArray, _RealWorld)
-import Unique ( Unique, mkUniqueGrimily )
-
-type Handle = _MutableArray _RealWorld Int _Handle
-data _Handle = _ErrorHandle IOError13 | _ClosedHandle | _SemiClosedHandle _Addr (_Addr, Int) | _ReadHandle _Addr (Maybe BufferMode) Bool | _WriteHandle _Addr (Maybe BufferMode) Bool | _AppendHandle _Addr (Maybe BufferMode) Bool | _ReadWriteHandle _Addr (Maybe BufferMode) Bool
-data Unique
-
-mkUniqueGrimily :: Int# -> Unique
-
-_filePtr :: _Handle -> _Addr
-_readHandle :: Handle -> IO _Handle
-_writeHandle :: Handle -> _Handle -> IO ()
-_constructError :: String -> PrimIO IOError13
-\end{code}
diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs
index d2737a4b7f..dfa2cd023f 100644
--- a/ghc/compiler/utils/ListSetOps.lhs
+++ b/ghc/compiler/utils/ListSetOps.lhs
@@ -4,8 +4,6 @@
\section[ListSetOps]{Set-like operations on lists}
\begin{code}
-#include "HsVersions.h"
-
module ListSetOps (
unionLists,
--UNUSED: intersectLists,
@@ -13,13 +11,10 @@ module ListSetOps (
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import Util ( isIn, isn'tIn )
-
-#if __GLASGOW_HASKELL__ >= 202
-import List
-#endif
+import List ( union )
\end{code}
\begin{code}
diff --git a/ghc/compiler/utils/MatchEnv.lhs b/ghc/compiler/utils/MatchEnv.lhs
deleted file mode 100644
index 6c09616e29..0000000000
--- a/ghc/compiler/utils/MatchEnv.lhs
+++ /dev/null
@@ -1,116 +0,0 @@
-%************************************************************************
-%* *
-\subsection[MatchEnv]{Matching environments}
-%* *
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-
-module MatchEnv (
- MatchEnv, nullMEnv, mkMEnv,
- isEmptyMEnv, lookupMEnv, insertMEnv,
- mEnvToList
-) where
-
-CHK_Ubiq() -- debugging consistency check
-
-import Maybes ( MaybeErr(..), returnMaB, thenMaB, failMaB )
-\end{code}
-
-``Matching'' environments allow you to bind a template to a value;
-when you look up in it, you supply a value which is matched against
-the template.
-
-\begin{code}
-data MatchEnv key value
- = EmptyME -- Common, so special-cased
- | ME [(key, value)]
-\end{code}
-
-For now we just use association lists. The list is maintained sorted
-in order of {\em decreasing specificness} of @key@, so that the first
-match will be the most specific.
-
-\begin{code}
-nullMEnv :: MatchEnv a b
-nullMEnv = EmptyME
-
-isEmptyMEnv EmptyME = True
-isEmptyMEnv _ = False
-
-mkMEnv :: [(key, value)] -> MatchEnv key value
-mkMEnv [] = EmptyME
-mkMEnv stuff = ME stuff
-
-mEnvToList :: MatchEnv key value -> [(key, value)]
-mEnvToList EmptyME = []
-mEnvToList (ME stuff) = stuff
-\end{code}
-
-@lookupMEnv@ looks up in a @MatchEnv@. It simply takes the first
-match, which should be the most specific.
-
-\begin{code}
-lookupMEnv :: (key1 {- template -} -> -- Matching function
- key2 {- instance -} ->
- Maybe match_info)
- -> MatchEnv key1 value -- The envt
- -> key2 -- Key
- -> Maybe (value, -- Value
- match_info) -- Match info returned by matching fn
-
-
-lookupMEnv key_match EmptyME key = Nothing
-lookupMEnv key_match (ME alist) key
- = find alist
- where
- find [] = Nothing
- find ((tpl, val) : rest)
- = case (key_match tpl key) of
- Nothing -> find rest
- Just match_info -> Just (val,match_info)
-\end{code}
-
-@insertMEnv@ extends a match environment, checking for overlaps.
-
-\begin{code}
-insertMEnv :: (key {- template -} -> -- Matching function
- key {- instance -} ->
- Maybe match_info)
- -> MatchEnv key value -- Envt
- -> key -> value -- New item
- -> MaybeErr (MatchEnv key value) -- Success...
- (key, value) -- Failure: Offending overlap
-
-insertMEnv match_fn EmptyME key value = returnMaB (ME [(key, value)])
-insertMEnv match_fn (ME alist) key value
- = insert alist
- where
- -- insertMEnv has to put the new item in BEFORE any keys which are
- -- LESS SPECIFIC than the new key, and AFTER any keys which are
- -- MORE SPECIFIC The list is maintained in specific-ness order, so
- -- we just stick it in either last, or just before the first key
- -- of which the new key is an instance. We check for overlap at
- -- that point.
-
- insert [] = returnMaB (ME [(key, value)])
- insert ls@(r@(t,v) : rest)
- = case (match_fn t key) of
- Nothing ->
- -- New key is not an instance of this existing one, so
- -- continue down the list.
- insert rest `thenMaB` \ (ME rest') ->
- returnMaB (ME(r:rest'))
-
- Just match_info ->
- -- New key *is* an instance of the old one, so check the
- -- other way round in case of identity.
-
- case (match_fn key t) of
- Just _ -> failMaB r
- -- Oops; overlap
-
- Nothing -> returnMaB (ME ((key,value):ls))
- -- All ok; insert here
-\end{code}
diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs
index 37a12e06b9..ce92316d6c 100644
--- a/ghc/compiler/utils/Maybes.lhs
+++ b/ghc/compiler/utils/Maybes.lhs
@@ -4,8 +4,6 @@
\section[Maybes]{The `Maybe' types and associated utility functions}
\begin{code}
-#include "HsVersions.h"
-
module Maybes (
-- Maybe(..), -- no, it's in 1.3
MaybeErr(..),
@@ -28,10 +26,9 @@ module Maybes (
catMaybes
) where
-#if __GLASGOW_HASKELL__ >= 204
-import Maybe ( catMaybes, mapMaybe )
-#endif
+#include "HsVersions.h"
+import Maybe( catMaybes, mapMaybe )
\end{code}
@@ -60,19 +57,6 @@ allMaybes (Just x : ms) = case (allMaybes ms) of
Nothing -> Nothing
Just xs -> Just (x:xs)
-#if __GLASGOW_HASKELL__ < 204
- -- After 2.04 we get these from the library Maybe
-catMaybes :: [Maybe a] -> [a]
-catMaybes [] = []
-catMaybes (Nothing : xs) = catMaybes xs
-catMaybes (Just x : xs) = (x : catMaybes xs)
-
-mapMaybe :: (a -> Maybe b) -> [a] -> [b]
-mapMaybe f [] = []
-mapMaybe f (x:xs) = case f x of
- Just y -> y : mapMaybe f xs
- Nothing -> mapMaybe f xs
-#endif
\end{code}
@firstJust@ takes a list of @Maybes@ and returns the
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index ea11887957..861f4b5f09 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -7,47 +7,47 @@ Defines classes for pretty-printing and forcing, both forms of
``output.''
\begin{code}
-#include "HsVersions.h"
-
module Outputable (
- Outputable(..), -- class
-
- PprStyle(..),
- codeStyle, ifaceStyle, userStyle,
- ifPprDebug,
- ifnotPprForUser,
- ifPprShowAll, ifnotPprShowAll,
- ifPprInterface,
- pprQuote,
-
- printDoc, printErrs, pprCols, pprDumpStyle, pprErrorsStyle,
-
- interppSP, interpp'SP,
-
- speakNth
-
-#if __GLASGOW_HASKELL__ <= 200
- , Mode
-#endif
-
+ Outputable(..), -- Class
+
+ PprStyle,
+ getPprStyle, withPprStyle, pprDeeper,
+ codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
+ ifPprDebug, ifNotPprForUser,
+
+ SDoc, -- Abstract
+ interppSP, interpp'SP, pprQuotedList,
+ empty, nest,
+ text, char, ptext,
+ int, integer, float, double, rational,
+ parens, brackets, braces, quotes, doubleQuotes,
+ semi, comma, colon, space, equals,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+ (<>), (<+>), hcat, hsep,
+ ($$), ($+$), vcat,
+ sep, cat,
+ fsep, fcat,
+ hang, punctuate,
+ speakNth, speakNTimes,
+
+ showSDoc, printSDoc, printErrs, printDump,
+ printForC, printForAsm, printForIface,
+ pprCols,
+
+ -- error handling
+ pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
+ panic, panic#, assertPanic
) where
-#if __GLASGOW_HASKELL__ >= 202
-import IO
-import GlaExts
-# if __GLASGOW_HASKELL__ >= 209
-import Addr
-# endif
-
-#else
-import Ubiq ( Uniquable(..), Unique, Name ) -- FastString mentions it; todo: rm
-
-#endif
+#include "HsVersions.h"
-import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User )
+import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
+import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprStyle_User, opt_PprUserLength )
import FastString
-import Pretty
-import Util ( cmpPString )
+import qualified Pretty
+import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
+import Util ( panic, assertPanic, panic# )
+import GlaExts ( trace )
\end{code}
@@ -59,26 +59,23 @@ import Util ( cmpPString )
\begin{code}
data PprStyle
- = PprForUser Int -- Pretty-print in a way that will
+ = PprUser Depth -- Pretty-print in a way that will
-- make sense to the ordinary user;
-- must be very close to Haskell
-- syntax, etc.
- -- Parameterised over how much to expand
- -- a pretty-printed value (<= 0 => stop pp).
- | PprQuote -- Like PprForUser, but also quote the whole thing
| PprDebug -- Standard debugging output
- | PprShowAll -- Debugging output which leaves
- -- nothing to the imagination
| PprInterface -- Interface generation
- | PprForC -- must print out C-acceptable names
+ | PprCode CodeStyle -- Print code; either C or assembler
- | PprForAsm -- must print out assembler-acceptable names
- Bool -- prefix CLabel with underscore?
- (String -> String) -- format AsmTempLabel
+data CodeStyle = CStyle -- The format of labels differs for C and assembler
+ | AsmStyle
+
+data Depth = AllTheWay
+ | PartWay Int -- 0 => stop
\end{code}
Orthogonal to the above printing styles are (possibly) some
@@ -88,37 +85,152 @@ shown.
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
+
+%************************************************************************
+%* *
+\subsection{The @SDoc@ data type}
+%* *
+%************************************************************************
+
+\begin{code}
+type SDoc = PprStyle -> Doc
+
+withPprStyle :: PprStyle -> SDoc -> SDoc
+withPprStyle sty d sty' = d sty
+
+pprDeeper :: SDoc -> SDoc
+pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
+pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
+pprDeeper d other_sty = d other_sty
+
+getPprStyle :: (PprStyle -> SDoc) -> SDoc
+getPprStyle df sty = df sty sty
+\end{code}
+
\begin{code}
codeStyle :: PprStyle -> Bool
-codeStyle PprForC = True
-codeStyle (PprForAsm _ _) = True
+codeStyle (PprCode _) = True
codeStyle _ = False
+asmStyle :: PprStyle -> Bool
+asmStyle (PprCode AsmStyle) = True
+asmStyle other = False
+
ifaceStyle :: PprStyle -> Bool
ifaceStyle PprInterface = True
ifaceStyle other = False
+debugStyle :: PprStyle -> Bool
+debugStyle PprDebug = True
+debugStyle other = False
+
userStyle :: PprStyle -> Bool
-userStyle PprQuote = True
-userStyle (PprForUser _) = True
-userStyle other = False
+userStyle (PprUser _) = True
+userStyle other = False
\end{code}
\begin{code}
-ifPprDebug sty p = case sty of PprDebug -> p ; _ -> empty
-ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> empty
-ifPprInterface sty p = case sty of PprInterface -> p ; _ -> empty
+ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
+ifNotPprForUser d sty@(PprUser _) = Pretty.empty
+ifNotPprForUser d sty = d sty
-ifnotPprForUser sty p = case sty of { PprForUser _ -> empty ; PprQuote -> empty; _ -> p }
-ifnotPprShowAll sty p = case sty of { PprShowAll -> empty ; _ -> p }
+ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
+ifPprDebug d sty@PprDebug = d sty
+ifPprDebug d sty = Pretty.empty
\end{code}
\begin{code}
-pprQuote :: PprStyle -> (PprStyle -> Doc) -> Doc
-pprQuote PprQuote fn = quotes (fn (PprForUser 5{-opt_PprUserLength-}))
-pprQuote sty fn = fn sty
+printSDoc :: SDoc -> PprStyle -> IO ()
+printSDoc d sty = printDoc PageMode stdout (d sty)
+
+-- I'm not sure whether the direct-IO approach of printDoc
+-- above is better or worse than the put-big-string approach here
+printErrs :: SDoc -> IO ()
+printErrs doc = printDoc PageMode stderr (final_doc user_style)
+ where
+ final_doc = doc $$ text ""
+ user_style = mkUserStyle (PartWay opt_PprUserLength)
+
+printDump :: SDoc -> IO ()
+printDump doc = printDoc PageMode stderr (final_doc PprDebug)
+ where
+ final_doc = doc $$ text ""
+
+
+-- printForC, printForAsm doe what they sound like
+printForC :: Handle -> SDoc -> IO ()
+printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
+
+printForAsm :: Handle -> SDoc -> IO ()
+printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
+
+-- printForIface prints all on one line for interface files.
+-- It's called repeatedly for successive lines
+printForIface :: Handle -> SDoc -> IO ()
+printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
+
+
+-- showSDoc just blasts it out as a string
+showSDoc :: SDoc -> String
+showSDoc d = show (d (mkUserStyle AllTheWay))
+
+mkUserStyle depth | opt_PprStyle_Debug
+ || opt_PprStyle_All = PprDebug
+ | otherwise = PprUser depth
\end{code}
+\begin{code}
+empty sty = Pretty.empty
+text s sty = Pretty.text s
+char c sty = Pretty.char c
+ptext s sty = Pretty.ptext s
+int n sty = Pretty.int n
+integer n sty = Pretty.integer n
+float n sty = Pretty.float n
+double n sty = Pretty.double n
+rational n sty = Pretty.rational n
+
+parens d sty = Pretty.parens (d sty)
+braces d sty = Pretty.braces (d sty)
+brackets d sty = Pretty.brackets (d sty)
+quotes d sty = Pretty.quotes (d sty)
+doubleQuotes d sty = Pretty.doubleQuotes (d sty)
+
+semi sty = Pretty.semi
+comma sty = Pretty.comma
+colon sty = Pretty.colon
+equals sty = Pretty.equals
+space sty = Pretty.space
+lparen sty = Pretty.lparen
+rparen sty = Pretty.rparen
+lbrack sty = Pretty.lbrack
+rbrack sty = Pretty.rbrack
+lbrace sty = Pretty.lbrace
+rbrace sty = Pretty.rbrace
+
+nest n d sty = Pretty.nest n (d sty)
+(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
+(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
+($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
+($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+
+hcat ds sty = Pretty.hcat [d sty | d <- ds]
+hsep ds sty = Pretty.hsep [d sty | d <- ds]
+vcat ds sty = Pretty.vcat [d sty | d <- ds]
+sep ds sty = Pretty.sep [d sty | d <- ds]
+cat ds sty = Pretty.cat [d sty | d <- ds]
+fsep ds sty = Pretty.fsep [d sty | d <- ds]
+fcat ds sty = Pretty.fcat [d sty | d <- ds]
+
+hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
+
+punctuate :: SDoc -> [SDoc] -> [SDoc]
+punctuate p [] = []
+punctuate p (d:ds) = go d ds
+ where
+ go d [] = [d]
+ go d (e:es) = (d <> p) : go e es
+\end{code}
%************************************************************************
@@ -129,30 +241,29 @@ pprQuote sty fn = fn sty
\begin{code}
class Outputable a where
- ppr :: PprStyle -> a -> Doc
+ ppr :: a -> SDoc
\end{code}
\begin{code}
instance Outputable Bool where
- ppr sty True = ptext SLIT("True")
- ppr sty False = ptext SLIT("False")
+ ppr False = ptext SLIT("False")
instance Outputable Int where
- ppr sty n = int n
+ ppr n = int n
instance (Outputable a) => Outputable [a] where
- ppr sty xs = brackets (fsep (punctuate comma (map (ppr sty) xs)))
+ ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
instance (Outputable a, Outputable b) => Outputable (a, b) where
- ppr sty (x,y) =
- hang (hcat [lparen, ppr sty x, comma]) 4 ((<>) (ppr sty y) rparen)
+ ppr (x,y) =
+ hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen)
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
- ppr sty (x,y,z) =
- parens (sep [ (<>) (ppr sty x) comma,
- (<>) (ppr sty y) comma,
- ppr sty z ])
+ ppr (x,y,z) =
+ parens (sep [ (<>) (ppr x) comma,
+ (<>) (ppr y) comma,
+ ppr z ])
\end{code}
@@ -165,13 +276,6 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher
\begin{code}
pprCols = (100 :: Int) -- could make configurable
--- pprErrorsStyle is the style to print ordinary error messages with
--- pprDumpStyle is the style to print -ddump-xx information in
-(pprDumpStyle, pprErrorsStyle)
- | opt_PprStyle_All = (PprShowAll, PprShowAll)
- | opt_PprStyle_Debug = (PprDebug, PprDebug)
- | otherwise = (PprDebug, PprQuote)
-
printDoc :: Mode -> Handle -> Doc -> IO ()
printDoc mode hdl doc
= fullRender mode pprCols 1.5 put done doc
@@ -181,21 +285,19 @@ printDoc mode hdl doc
put (PStr s) next = hPutFS hdl s >> next
done = hPutChar hdl '\n'
-
--- I'm not sure whether the direct-IO approach of printDoc
--- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = hPutStr stderr (show (doc $$ text ""))
\end{code}
\begin{code}
-interppSP :: Outputable a => PprStyle -> [a] -> Doc
-interppSP sty xs = hsep (map (ppr sty) xs)
+interppSP :: Outputable a => [a] -> SDoc
+interppSP xs = hsep (map ppr xs)
-interpp'SP :: Outputable a => PprStyle -> [a] -> Doc
-interpp'SP sty xs
- = hsep (punctuate comma (map (ppr sty) xs))
+interpp'SP :: Outputable a => [a] -> SDoc
+interpp'SP xs = hsep (punctuate comma (map ppr xs))
+
+pprQuotedList :: Outputable a => [a] -> SDoc
+-- [x,y,z] ==> `x', `y', `z'
+pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
\end{code}
@@ -211,7 +313,7 @@ interpp'SP sty xs
``first'' etc.
\begin{code}
-speakNth :: Int -> Doc
+speakNth :: Int -> SDoc
speakNth 1 = ptext SLIT("first")
speakNth 2 = ptext SLIT("second")
@@ -228,3 +330,41 @@ speakNth n = hcat [ int n, text st_nd_rd_th ]
n_rem_10 = n `rem` 10
\end{code}
+
+\begin{code}
+speakNTimes :: Int {- >=1 -} -> SDoc
+speakNTimes t | t == 1 = ptext SLIT("once")
+ | t == 2 = ptext SLIT("twice")
+ | otherwise = int t <+> ptext SLIT("times")
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Utils-errors]{Error handling}
+%* *
+%************************************************************************
+
+\begin{code}
+pprPanic heading pretty_msg = panic (show (doc PprDebug))
+ where
+ doc = text heading <+> pretty_msg
+
+pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
+
+pprTrace heading pretty_msg = trace (show (doc PprDebug))
+ where
+ doc = text heading <+> pretty_msg
+
+pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
+ where
+ doc = text heading <+> pretty_msg
+
+assertPprPanic :: String -> Int -> SDoc -> a
+assertPprPanic file line msg
+ = panic (show (doc PprDebug))
+ where
+ doc = sep [hsep[text "ASSERT failed! file",
+ text file,
+ text "line", int line],
+ msg]
+\end{code}
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index 54abced398..41cdb1a5d0 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -98,8 +98,6 @@ Relative to John's original paper, there are the following new features:
\begin{code}
-#include "HsVersions.h"
-
module Pretty (
Doc, -- Abstract
Mode(..), TextDetails(..),
@@ -124,22 +122,10 @@ module Pretty (
) where
#include "HsVersions.h"
-#if defined(__GLASGOW_HASKELL__)
import FastString
-
-#if __GLASGOW_HASKELL__ >= 202
-
import GlaExts
-#else
-
- -- Horrible import to satisfy GHC 0.29
-import Ubiq ( Unique, Uniquable(..), Name )
-
-#endif
-#endif
-
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
infixl 6 <>
diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs
index 78f0071463..10216452f6 100644
--- a/ghc/compiler/utils/PrimPacked.lhs
+++ b/ghc/compiler/utils/PrimPacked.lhs
@@ -8,20 +8,13 @@ of bytes (character strings). Used by the interface lexer input
subsystem, mostly.
\begin{code}
-#include "HsVersions.h"
-
module PrimPacked
(
strLength, -- :: _Addr -> Int
- copyPrefixStr, -- :: _Addr -> Int -> _ByteArray Int
- copySubStr, -- :: _Addr -> Int -> Int -> _ByteArray Int
- copySubStrFO, -- :: ForeignObj -> Int -> Int -> _ByteArray Int
- copySubStrBA, -- :: _ByteArray Int -> Int -> Int -> _ByteArray Int
-
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
- stringToByteArray, -- :: String -> _ByteArray Int
- byteArrayToString, -- :: _ByteArray Int -> String
-#endif
+ copyPrefixStr, -- :: _Addr -> Int -> ByteArray Int
+ copySubStr, -- :: _Addr -> Int -> Int -> ByteArray Int
+ copySubStrFO, -- :: ForeignObj -> Int -> Int -> ByteArray Int
+ copySubStrBA, -- :: ByteArray Int -> Int -> Int -> ByteArray Int
eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
@@ -33,41 +26,29 @@ module PrimPacked
indexCharOffFO# -- :: ForeignObj# -> Int# -> Char#
) where
-#if __GLASGOW_HASKELL__ <= 201
-import PreludeGlaST
-import PreludeGlaMisc
-#else
+-- This #define suppresses the "import FastString" that
+-- HsVersions otherwise produces
+#define COMPILING_FAST_STRING
+#include "HsVersions.h"
+
import GlaExts
-import Foreign
+import Addr ( Addr(..) )
import GHC
import ArrBase
import ST
import STBase
-
-# if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char(..) )
-# endif
-
-# if __GLASGOW_HASKELL__ >= 206
-import PackBase
-# endif
-
-# if __GLASGOW_HASKELL__ >= 209
-import Addr
-# endif
-
-#endif
-
+import IOBase ( ForeignObj(..) )
+import PackBase ( unpackCStringBA, packString )
\end{code}
Return the length of a @\\NUL@ terminated character string:
\begin{code}
-strLength :: _Addr -> Int
+strLength :: Addr -> Int
strLength a =
- unsafePerformPrimIO (
- _ccall_ strlen a `thenPrimIO` \ len@(I# _) ->
- returnPrimIO len
+ unsafePerformIO (
+ _ccall_ strlen a >>= \ len@(I# _) ->
+ return len
)
\end{code}
@@ -77,21 +58,24 @@ Copying a char string prefix into a byte array,
NULs.
\begin{code}
-
-copyPrefixStr :: _Addr -> Int -> _ByteArray Int
+copyPrefixStr :: Addr -> Int -> ByteArray Int
copyPrefixStr (A# a) len@(I# length#) =
- unsafePerformST (
+ runST (
{- allocate an array that will hold the string
(not forgetting the NUL at the end)
-}
- new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
+ (new_ps_array (length# +# 1#)) >>= \ ch_array ->
+{- Revert back to Haskell-only solution for the moment.
+ _ccall_ memcpy ch_array (A# a) len >>= \ () ->
+ write_ps_array ch_array length# (chr# 0#) >>
+-}
-- fill in packed string from "addr"
- fill_in ch_array 0# `thenStrictlyST` \ _ ->
+ fill_in ch_array 0# >>
-- freeze the puppy:
- freeze_ps_array ch_array `thenStrictlyST` \ barr ->
+ freeze_ps_array ch_array length# `thenStrictlyST` \ barr ->
returnStrictlyST barr )
where
- fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
@@ -108,20 +92,20 @@ Copying out a substring, assume a 0-indexed string:
(and positive lengths, thank you).
\begin{code}
-copySubStr :: _Addr -> Int -> Int -> _ByteArray Int
+copySubStr :: Addr -> Int -> Int -> ByteArray Int
copySubStr a start length =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
- `thenPrimIO` \ a_start ->
- returnPrimIO (copyPrefixStr a_start length))
+ >>= \ a_start ->
+ return (copyPrefixStr a_start length))
\end{code}
-Copying a sub-string out of a ForeignObj
+pCopying a sub-string out of a ForeignObj
\begin{code}
-copySubStrFO :: _ForeignObj -> Int -> Int -> _ByteArray Int
-copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
- unsafePerformST (
+copySubStrFO :: ForeignObj -> Int -> Int -> ByteArray Int
+copySubStrFO (ForeignObj fo) (I# start#) len@(I# length#) =
+ runST (
{- allocate an array that will hold the string
(not forgetting the NUL at the end)
-}
@@ -129,9 +113,9 @@ copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
-- fill in packed string from "addr"
fill_in ch_array 0# `seqStrictlyST`
-- freeze the puppy:
- freeze_ps_array ch_array)
+ freeze_ps_array ch_array length#)
where
- fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
@@ -146,7 +130,7 @@ copySubStrFO (_ForeignObj fo) (I# start#) len@(I# length#) =
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <=205
indexCharOffFO# :: ForeignObj# -> Int# -> Char#
indexCharOffFO# fo# i# =
- case unsafePerformPrimIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (_ForeignObj fo#) (I# i#)) of
+ case unsafePerformIO (_casm_ ``%r=(char)*((char *)%0 + (int)%1); '' (ForeignObj fo#) (I# i#)) of
C# c -> c
#else
indexCharOffFO# :: ForeignObj# -> Int# -> Char#
@@ -156,22 +140,22 @@ indexCharOffFO# fo i = indexCharOffForeignObj# fo i
-- step on (char *) pointer by x units.
addrOffset# :: Addr# -> Int# -> Addr#
addrOffset# a# i# =
- case unsafePerformPrimIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
+ case unsafePerformIO (_casm_ ``%r=(char *)((char *)%0 + (int)%1); '' (A# a#) (I# i#)) of
A# a -> a
-copySubStrBA :: _ByteArray Int -> Int -> Int -> _ByteArray Int
-copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) =
- unsafePerformST (
+copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int
+copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) =
+ runST (
{- allocate an array that will hold the string
(not forgetting the NUL at the end)
-}
new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
-- fill in packed string from "addr"
- fill_in ch_array 0# `seqStrictlyST`
+ fill_in ch_array 0# `seqStrictlyST`
-- freeze the puppy:
- freeze_ps_array ch_array)
+ freeze_ps_array ch_array length#)
where
- fill_in :: _MutableByteArray s Int -> Int# -> _ST s ()
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
@@ -185,146 +169,98 @@ copySubStrBA (_ByteArray _ barr#) (I# start#) len@(I# length#) =
\end{code}
(Very :-) ``Specialised'' versions of some CharArray things...
+[Copied from PackBase; no real reason -- UGH]
\begin{code}
-new_ps_array :: Int# -> _ST s (_MutableByteArray s Int)
-write_ps_array :: _MutableByteArray s Int -> Int# -> Char# -> _ST s ()
-freeze_ps_array :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
+new_ps_array :: Int# -> ST s (MutableByteArray s Int)
+write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
+freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)
-new_ps_array size =
- MkST ( \ STATE_TOK(s#) ->
- case (newCharArray# size s#) of { StateAndMutableByteArray# s2# barr# ->
- ST_RET(_MutableByteArray (0, max 0 (I# (size -# 1#))) barr#, STATE_TOK(s2#))})
+new_ps_array size = ST $ \ s ->
+ case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
+ STret s2# (MutableByteArray bot barr#) }
+ where
+ bot = error "new_ps_array"
-write_ps_array (_MutableByteArray _ barr#) n ch =
- MkST ( \ STATE_TOK(s#) ->
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
- ST_RET((), STATE_TOK(s2#) )})
+ STret s2# () }
-- same as unsafeFreezeByteArray
-freeze_ps_array (_MutableByteArray ixs arr#) =
- MkST ( \ STATE_TOK(s#) ->
+freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# ->
case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- ST_RET((_ByteArray ixs frozen#), STATE_TOK(s2#))})
+ STret s2# (ByteArray (0,I# len#) frozen#) }
\end{code}
+
Compare two equal-length strings for equality:
\begin{code}
eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
eqStrPrefix a# barr# len# =
- unsafePerformPrimIO (
- _ccall_ strncmp (A# a#) (_ByteArray bottom barr#) (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ unsafePerformIO (
+ _ccall_ strncmp (A# a#) (ByteArray bottom barr#) (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefix"
eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool
eqCharStrPrefix a1# a2# len# =
- unsafePerformPrimIO (
- _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ unsafePerformIO (
+ _ccall_ strncmp (A# a1#) (A# a2#) (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefix"
eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixBA b1# b2# start# len# =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (_ByteArray bottom b2#)
+ (ByteArray bottom b2#)
(I# start#)
- (_ByteArray bottom b1#)
- (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ (ByteArray bottom b1#)
+ (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefixBA"
eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
eqCharStrPrefixBA a# b2# start# len# =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (_ByteArray bottom b2#)
+ (ByteArray bottom b2#)
(I# start#)
(A# a#)
- (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqCharStrPrefixBA"
eqStrPrefixFO :: ForeignObj# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixFO fo# barr# start# len# =
- unsafePerformPrimIO (
+ unsafePerformIO (
_casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); ''
- (_ForeignObj fo#)
+ (ForeignObj fo#)
(I# start#)
- (_ByteArray bottom barr#)
- (I# len#) `thenPrimIO` \ (I# x#) ->
- returnPrimIO (x# ==# 0#))
+ (ByteArray bottom barr#)
+ (I# len#) >>= \ (I# x#) ->
+ return (x# ==# 0#))
where
bottom :: (Int,Int)
bottom = error "eqStrPrefixFO"
\end{code}
\begin{code}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 205
-byteArrayToString :: _ByteArray Int -> String
-byteArrayToString (_ByteArray (I# start#,I# end#) barr#) =
- unpack start#
- where
- unpack nh#
- | nh# >=# end# = []
- | otherwise = C# ch : unpack (nh# +# 1#)
- where
- ch = indexCharArray# barr# nh#
-#elif defined(__GLASGOW_HASKELL__)
-byteArrayToString :: _ByteArray Int -> String
+byteArrayToString :: ByteArray Int -> String
byteArrayToString = unpackCStringBA
-#else
-#error "byteArrayToString: cannot handle this!"
-#endif
-
\end{code}
\begin{code}
-stringToByteArray :: String -> (_ByteArray Int)
-#if __GLASGOW_HASKELL__ >= 206
+stringToByteArray :: String -> (ByteArray Int)
stringToByteArray = packString
-#elif defined(__GLASGOW_HASKELL__)
-stringToByteArray str = _runST (packStringST str)
-
-packStringST :: [Char] -> _ST s (_ByteArray Int)
-packStringST str =
- let len = length str in
- packNCharsST len str
-
-packNCharsST :: Int -> [Char] -> _ST s (_ByteArray Int)
-packNCharsST len@(I# length#) str =
- {-
- allocate an array that will hold the string
- (not forgetting the NUL byte at the end)
- -}
- new_ps_array (length# +# 1#) `thenStrictlyST` \ ch_array ->
- -- fill in packed string from "str"
- fill_in ch_array 0# str `seqStrictlyST`
- -- freeze the puppy:
- freeze_ps_array ch_array `thenStrictlyST` \ (_ByteArray _ frozen#) ->
- returnStrictlyST (_ByteArray (0,len) frozen#)
- where
- fill_in :: _MutableByteArray s Int -> Int# -> [Char] -> _ST s ()
- fill_in arr_in# idx [] =
- write_ps_array arr_in# idx (chr# 0#) `seqStrictlyST`
- returnStrictlyST ()
-
- fill_in arr_in# idx (C# c : cs) =
- write_ps_array arr_in# idx c `seqStrictlyST`
- fill_in arr_in# (idx +# 1#) cs
-#else
-#error "stringToByteArray: cannot handle this"
-#endif
-
\end{code}
diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs
index 110375056a..ac147dc920 100644
--- a/ghc/compiler/utils/SST.lhs
+++ b/ghc/compiler/utils/SST.lhs
@@ -2,86 +2,83 @@
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-#include "HsVersions.h"
-
module SST(
- SYN_IE(SST), SST_R, SYN_IE(FSST), FSST_R,
+ SST, SST_R, FSST, FSST_R,
- runSST, sstToST, stToSST,
+ runSST, sstToST, stToSST, ioToSST,
thenSST, thenSST_, returnSST, fixSST,
thenFSST, thenFSST_, returnFSST, failFSST,
recoverFSST, recoverSST, fixFSST,
unsafeInterleaveSST,
- newMutVarSST, readMutVarSST, writeMutVarSST
-#if __GLASGOW_HASKELL__ >= 200
- , MutableVar
-#else
- , MutableVar(..), _MutableArray
-#endif
+ newMutVarSST, readMutVarSST, writeMutVarSST,
+ SSTRef
) where
-#if __GLASGOW_HASKELL__ == 201
-import GHCbase
-#elif __GLASGOW_HASKELL__ >= 202
+#include "HsVersions.h"
+
import GlaExts
import STBase
+import IOBase ( IO(..), IOResult(..) )
import ArrBase
import ST
-#else
-import PreludeGlaST ( MutableVar(..), _MutableArray(..), ST(..) )
-#endif
-
-CHK_Ubiq() -- debugging consistency check
\end{code}
+@SST@ is very like the standard @ST@ monad, but it comes with its
+friend @FSST@. Because we want the monadic bind operator to work
+for mixtures of @SST@ and @FSST@, we can't use @ST@ at all.
+
+For simplicity we don't even dress them up in newtypes.
+
+%************************************************************************
+%* *
+\subsection{The data types}
+%* *
+%************************************************************************
+
\begin{code}
+type SST s r = State# s -> SST_R s r
+type FSST s r err = State# s -> FSST_R s r err
+
data SST_R s r = SST_R r (State# s)
-type SST s r = State# s -> SST_R s r
+data FSST_R s r err
+ = FSST_R_OK r (State# s)
+ | FSST_R_Fail err (State# s)
\end{code}
-\begin{code}
--- converting to/from ST
+Converting to/from ST
+\begin{code}
sstToST :: SST s r -> ST s r
stToSST :: ST s r -> SST s r
-#if __GLASGOW_HASKELL__ >= 200 && __GLASGOW_HASKELL__ < 209
-
-sstToST sst = ST $ \ (S# s) ->
- case sst s of SST_R r s' -> (r, S# s')
+sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
-stToSST (ST st) = \ s ->
- case st (S# s) of (r, S# s') -> SST_R r s'
-
-#elif __GLASGOW_HASKELL__ >= 209
+stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
+\end{code}
-sstToST sst = ST $ \ s ->
- case sst s of SST_R r s' -> STret s' r
+...and IO
-stToSST (ST st) = \ s ->
- case st s of STret s' r -> SST_R r s'
+\begin{code}
+ioToSST :: IO a -> SST RealWorld (Either IOError a)
+ioToSST (IO io)
+ = \s -> case io s of
+ IOok s' r -> SST_R (Right r) s'
+ IOfail s' err -> SST_R (Left err) s'
+\end{code}
-#else
-sstToST sst (S# s)
- = case sst s of SST_R r s' -> (r, S# s')
-stToSST st s
- = case st (S# s) of (r, S# s') -> SST_R r s'
-#endif
+%************************************************************************
+%* *
+\subsection{The @SST@ operations}
+%* *
+%************************************************************************
+\begin{code}
-- Type of runSST should be builtin ...
-- runSST :: forall r. (forall s. SST s r) -> r
-#if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD RealWorld
-# define MUT_ARRAY MutableArray
-#else
-# define REAL_WORLD _RealWorld
-# define MUT_ARRAY _MutableArray
-#endif
-
-runSST :: SST REAL_WORLD r -> r
+runSST :: SST RealWorld r -> r
runSST m = case m realWorld# of SST_R r s -> r
unsafeInterleaveSST :: SST s r -> SST s r
@@ -90,13 +87,24 @@ unsafeInterleaveSST m s = SST_R r s -- Duplicates the state!
SST_R r _ = m s
returnSST :: r -> SST s r
-thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
-thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
fixSST :: (r -> SST s r) -> SST s r
{-# INLINE returnSST #-}
{-# INLINE thenSST #-}
{-# INLINE thenSST_ #-}
+returnSST r s = SST_R r s
+
+fixSST m s = result
+ where
+ result = m loop s
+ SST_R loop _ = result
+\end{code}
+
+OK, here comes the clever bind operator.
+
+\begin{code}
+thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
+thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
-- Hence:
-- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
-- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
@@ -108,26 +116,14 @@ fixSST :: (r -> SST s r) -> SST s r
thenSST m k s = case m s of { SST_R r s' -> k r s' }
thenSST_ m k s = case m s of { SST_R r s' -> k s' }
-
-returnSST r s = SST_R r s
-
-fixSST m s = result
- where
- result = m loop s
- SST_R loop _ = result
\end{code}
-\section{FSST: the failable strict state transformer monad}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-data FSST_R s r err
- = FSST_R_OK r (State# s)
- | FSST_R_Fail err (State# s)
-
-type FSST s r err = State# s -> FSST_R s r err
-\end{code}
+%************************************************************************
+%* *
+\subsection{FSST: the failable strict state transformer monad}
+%* *
+%************************************************************************
\begin{code}
failFSST :: err -> FSST s r err
@@ -170,26 +166,32 @@ fixFSST m s = result
FSST_R_OK loop _ = result
\end{code}
-Mutables
-~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Mutables}
+%* *
+%************************************************************************
+
Here we implement mutable variables. ToDo: get rid of the array impl.
\begin{code}
-newMutVarSST :: a -> SST s (MutableVar s a)
-readMutVarSST :: MutableVar s a -> SST s a
-writeMutVarSST :: MutableVar s a -> a -> SST s ()
+type SSTRef s a = MutableArray s Int a
+
+newMutVarSST :: a -> SST s (SSTRef s a)
+readMutVarSST :: SSTRef s a -> SST s a
+writeMutVarSST :: SSTRef s a -> a -> SST s ()
newMutVarSST init s#
= case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
- SST_R (MUT_ARRAY vAR_IXS arr#) s2# }
+ SST_R (MutableArray vAR_IXS arr#) s2# }
where
vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
-readMutVarSST (MUT_ARRAY _ var#) s#
+readMutVarSST (MutableArray _ var#) s#
= case readArray# var# 0# s# of { StateAndPtr# s2# r ->
SST_R r s2# }
-writeMutVarSST (MUT_ARRAY _ var#) val s#
+writeMutVarSST (MutableArray _ var#) val s#
= case writeArray# var# 0# val s# of { s2# ->
SST_R () s2# }
\end{code}
diff --git a/ghc/compiler/utils/SpecLoop.lhi b/ghc/compiler/utils/SpecLoop.lhi
deleted file mode 100644
index a85c98f5a1..0000000000
--- a/ghc/compiler/utils/SpecLoop.lhi
+++ /dev/null
@@ -1,62 +0,0 @@
-This loop-breaking module is used solely to braek the loops caused by
-SPECIALIZE pragmas.
-
-\begin{code}
-interface SpecLoop where
-
-import RdrHsSyn ( RdrName )
-import Name ( Name, OccName )
-import TyVar ( GenTyVar )
-import TyCon ( TyCon )
-import Class ( GenClass, GenClassOp )
-import Id ( GenId )
-import Unique ( Unique, Uniquable(..) )
-import MachRegs ( Reg )
-import CLabel ( CLabel )
-
-data RdrName
-data GenClass a b
-data GenClassOp a
-data GenId a -- NB: fails the optimisation criterion
-data GenTyVar a -- NB: fails the optimisation criterion
-data Name
-data OccName
-data TyCon
-data Unique
-data Reg
-data CLabel
-
-
-class Uniquable a where
- uniqueOf :: a -> Unique
-
--- SPECIALIZing in FiniteMap
-instance Eq Reg
-instance Eq CLabel
-instance Eq OccName
-instance Eq RdrName
-instance Eq (GenId a)
-instance Eq TyCon
-instance Eq (GenClass a b)
-instance Eq Unique
-instance Eq Name
-
-instance Ord Reg
-instance Ord CLabel
-instance Ord OccName
-instance Ord RdrName
-instance Ord (GenId a)
-instance Ord TyCon
-instance Ord (GenClass a b)
-instance Ord Unique
-instance Ord Name
-
--- SPECIALIZing in UniqFM, UniqSet
-instance Uniquable (GenId a)
-instance Uniquable TyCon
-instance Uniquable (GenClass a b)
-instance Uniquable Unique
-instance Uniquable Name
-
--- SPECIALIZing in Name
-\end{code}
diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index 5c070daf4f..3119a13c49 100644
--- a/ghc/compiler/utils/StringBuffer.lhs
+++ b/ghc/compiler/utils/StringBuffer.lhs
@@ -6,7 +6,12 @@
Buffers for scanning string input stored in external arrays.
\begin{code}
-#include "HsVersions.h"
+
+{-# OPTIONS -fno-prune-tydecls #-}
+-- Don't really understand this!
+-- ERROR: Can't see the data constructor(s) for _ccall_/_casm_ argument;
+-- type: ForeignObj(try compiling with -fno-prune-tydecls ..)
+
module StringBuffer
(
@@ -56,32 +61,20 @@ module StringBuffer
lexemeToBuffer, -- :: StringBuffer -> StringBuffer
FastString,
- _ByteArray
+ ByteArray
) where
-#if __GLASGOW_HASKELL__ <= 200
-import PreludeGlaST
-import PreludeGlaMisc
-import HandleHack
-import Ubiq
-#else
+#include "HsVersions.h"
+
import GlaExts
+import Addr ( Addr(..) )
import Foreign
import IOBase
import IOHandle
import ST
import STBase
-import Char (isDigit)
-# if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char(..) )
-# endif
-# if __GLASGOW_HASKELL__ >= 206
+import Char (isDigit)
import PackBase
-# endif
-# if __GLASGOW_HASKELL__ >= 209
-import Addr
-# endif
-#endif
import PrimPacked
import FastString
@@ -112,36 +105,36 @@ hGetStringBuffer fname =
-- Allocate an array for system call to store its bytes into.
-- ToDo: make it robust
-- trace (show ((len_i::Int)+1)) $
- (_casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int)) `CCALL_THEN` \ arr@(A# a#) ->
+ _casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int) >>= \ arr@(A# a#) ->
if addr2Int# a# ==# 0# then
failWith MkIOError(hndl,UserError,("hGetStringBuffer: Could not allocate "++show len_i ++ " bytes"))
else
--- _casm_ `` %r=NULL; '' `thenPrimIO` \ free_p ->
--- makeForeignObj arr free_p `thenPrimIO` \ fo@(_ForeignObj fo#) ->
- _readHandle hndl >>= \ hndl_ ->
- _writeHandle hndl hndl_ >>
+-- _casm_ `` %r=NULL; '' >>= \ free_p ->
+-- makeForeignObj arr free_p >>= \ fo@(_ForeignObj fo#) ->
+ readHandle hndl >>= \ hndl_ ->
+ writeHandle hndl hndl_ >>
let ptr = _filePtr hndl_ in
- _ccall_ fread arr (1::Int) len_i ptr `CCALL_THEN` \ (I# read#) ->
+ _ccall_ fread arr (1::Int) len_i ptr >>= \ (I# read#) ->
-- trace ("DEBUG: opened " ++ fname ++ show (I# read#)) $
hClose hndl >>
if read# ==# 0# then -- EOF or other error
failWith MkIOError(hndl,UserError,"hGetStringBuffer: EOF reached or some other error")
else
-- Add a sentinel NUL
- _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' arr (I# (read# -# 1#)) `CCALL_THEN` \ () ->
+ _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' arr (I# (read# -# 1#)) >>= \ () ->
return (StringBuffer a# read# 0# 0#)
freeStringBuffer :: StringBuffer -> IO ()
freeStringBuffer (StringBuffer a# _ _ _) =
- _casm_ `` free((char *)%0); '' (A# a#) `CCALL_THEN` \ () ->
- return ()
+ _casm_ `` free((char *)%0); '' (A# a#)
unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer
unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
- unsafePerformPrimIO (
- _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) `thenPrimIO` \ () ->
- returnPrimIO s)
+ unsafePerformIO (
+ _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) >>= \ () ->
+ return s
+ )
\end{code}
diff --git a/ghc/compiler/utils/Ubiq.hs b/ghc/compiler/utils/Ubiq.hs
deleted file mode 100644
index c66085da1f..0000000000
--- a/ghc/compiler/utils/Ubiq.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Ubiq
- (
- module Unique,
- module UniqFM
-
- ) where
-
-import Unique
-import UniqFM
-
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
deleted file mode 100644
index dc0b46586a..0000000000
--- a/ghc/compiler/utils/Ubiq.lhi
+++ /dev/null
@@ -1,152 +0,0 @@
-Things which are ubiquitous in the GHC compiler.
-
-\begin{code}
-interface Ubiq where
-
-import FastString(FastString)
-
-import BasicTypes ( Module(..), Arity(..) )
-import Bag ( Bag )
-import BinderInfo ( BinderInfo )
-import CgBindery ( CgIdInfo )
-import CLabel ( CLabel )
-import Class ( GenClass, GenClassOp, Class(..), ClassOp )
-import ClosureInfo ( ClosureInfo, LambdaFormInfo )
-import CmdLineOpts ( SimplifierSwitch, SwitchResult )
-import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
- GenCoreCaseAlts, GenCoreCaseDefault, Coercion
- )
-import CoreUnfold ( Unfolding, UnfoldingGuidance )
-import CostCentre ( CostCentre )
-import FieldLabel ( FieldLabel )
-import FiniteMap ( FiniteMap )
-import HeapOffs ( HeapOffset )
-import HsPat ( OutPat )
-import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas )
-import Id ( StrictnessMark, GenId, Id(..) )
-import IdInfo ( IdInfo, ArityInfo, StrictnessInfo, UpdateInfo )
-import Demand ( Demand )
-import Kind ( Kind )
-import Literal ( Literal )
-import MachRegs ( Reg )
-import Maybes ( MaybeErr )
-import MatchEnv ( MatchEnv )
-import Name ( OccName, Name, ExportFlag, NamedThing(..) )
-import Outputable ( Outputable(..), PprStyle )
-import PragmaInfo ( PragmaInfo )
-import Pretty ( Doc )
-import PrimOp ( PrimOp )
-import PrimRep ( PrimRep )
-import SMRep ( SMRep )
-import SrcLoc ( SrcLoc )
-import TcType ( TcMaybe )
-import TyCon ( TyCon )
-import TyVar ( GenTyVar, TyVar(..) )
-import Type ( GenType, Type(..) )
-import UniqFM ( UniqFM )
-import UniqSupply ( UniqSupply )
-import Unique ( Unique, Uniquable(..) )
-import Usage ( GenUsage, Usage(..) )
-import Util ( Ord3(..) )
-
--- All the classes in GHC go; life is just too short
--- to try to contain their visibility.
-
-class NamedThing a where
- getOccName :: a -> OccName
- getName :: a -> Name
-
-class Ord3 a where
- cmp :: a -> a -> Int#
-class Outputable a where
- ppr :: PprStyle -> a -> Doc
-class Uniquable a where
- uniqueOf :: a -> Unique
-
--- For datatypes, we ubiquitize those types that (a) are
--- used everywhere and (b) the compiler doesn't lose much
--- optimisation-wise by not seeing their pragma-gunk.
-
-data ArityInfo
-data Bag a
-data BinderInfo
-data CgIdInfo
-data CLabel
-data ClassOpPragmas a
-data ClassPragmas a
-data ClosureInfo
-data Coercion
-data CostCentre
-data DataPragmas a
-data Demand
-data ExportFlag
-data FieldLabel
-data FiniteMap a b
-data GenClass a b
-data GenClassOp a
-data GenCoreArg a b c
-data GenCoreBinder a b c
-data GenCoreBinding a b c d
-data GenCoreCaseAlts a b c d
-data GenCoreCaseDefault a b c d
-data GenCoreExpr a b c d
-data GenId a -- NB: fails the optimisation criterion
-data GenPragmas a
-data GenTyVar a -- NB: fails the optimisation criterion
-data GenType a b
-data GenUsage a
-data HeapOffset
-data IdInfo
-data InstancePragmas a
-data Kind
-data LambdaFormInfo
-data Literal
-data MaybeErr a b
-data MatchEnv a b
-data Name
-data OccName
-data Reg
-data OutPat a b c
-data PprStyle
-data PragmaInfo
-data Doc
-data PrimOp
-data PrimRep -- NB: an enumeration
-data SimplifierSwitch
-data SMRep
-data SrcLoc
-data StrictnessInfo
-data StrictnessMark
-data SwitchResult
-data TcMaybe s
-data TyCon
-data UniqFM a
-data UpdateInfo
-data UniqSupply
-data Unfolding
-data UnfoldingGuidance
-data Unique -- NB: fails the optimisation criterion
-
--- don't get clever and unexpand some of these synonyms
--- (GHC 0.26 will barf)
-type Module = FastString
-type Arity = Int
-type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
-type ClassOp = GenClassOp (GenType (GenTyVar (GenUsage Unique)) Unique)
-type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
-type Type = GenType (GenTyVar (GenUsage Unique)) Unique
-type TyVar = GenTyVar (GenUsage Unique)
-type Usage = GenUsage Unique
-
--- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
-instance Ord Reg
-instance Ord CLabel
-instance Ord TyCon
-instance Eq Reg
-instance Eq CLabel
-instance Eq TyCon
--- specializing in UniqFM, UniqSet
-instance Uniquable Unique
-instance Uniquable Name
--- specializing in Name
-\end{code}
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 3ce6713a92..2fec976bc3 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -11,8 +11,6 @@ Basically, the things need to be in class @Uniquable@, and we use the
(A similar thing to @UniqSet@, as opposed to @Set@.)
\begin{code}
-#include "HsVersions.h"
-
module UniqFM (
UniqFM, -- abstract type
@@ -41,23 +39,19 @@ module UniqFM (
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM,
- ufmToList
- ,FAST_STRING
+ ufmToList,
+ FastString
) where
-IMP_Ubiq()
+#include "HsVersions.h"
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER( SpecLoop )
-#else
-import {-# SOURCE #-} Name
-#endif
+import {-# SOURCE #-} Name ( Name )
import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily )
import Util
-import Pretty ( Doc )
-import Outputable ( PprStyle, Outputable(..) )
+import Outputable ( Outputable(..) )
import SrcLoc ( SrcLoc )
+import GlaExts -- Lots of Int# operations
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs
index 2f53d068bc..13b3eae53f 100644
--- a/ghc/compiler/utils/UniqSet.lhs
+++ b/ghc/compiler/utils/UniqSet.lhs
@@ -8,10 +8,8 @@ Based on @UniqFMs@ (as you would expect).
Basically, the things need to be in class @Uniquable@.
\begin{code}
-#include "HsVersions.h"
-
module UniqSet (
- SYN_IE(UniqSet), -- abstract type: NOT
+ UniqSet, -- abstract type: NOT
mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
addOneToUniqSet, addListToUniqSet,
@@ -20,19 +18,15 @@ module UniqSet (
isEmptyUniqSet, filterUniqSet, sizeUniqSet
) where
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER( SpecLoop )
-#else
+#include "HsVersions.h"
+
import {-# SOURCE #-} Name
-#endif
import Maybes ( maybeToBool )
import UniqFM
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
-import Outputable ( PprStyle, Outputable(..) )
-import Pretty ( Doc )
-import Util ( Ord3(..) )
+import Outputable ( Outputable(..) )
#if ! OMIT_NATIVE_CODEGEN
#define IF_NCG(a) a
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 97ca5242ff..34d36ae472 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -4,25 +4,12 @@
\section[Util]{Highly random utility functions}
\begin{code}
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-
-#ifndef __GLASGOW_HASKELL__
-# undef TAG_
-# undef LT_
-# undef EQ_
-# undef GT_
-# undef tagCmp_
-#endif
+-- IF_NOT_GHC is meant to make this module useful outside the context of GHC
+#define IF_NOT_GHC(a)
module Util (
- -- Haskell-version support
-#ifndef __GLASGOW_HASKELL__
- tagCmp_,
- TAG_(..),
-#endif
-- The Eager monad
- SYN_IE(Eager), thenEager, returnEager, mapEager, appEager, runEager,
+ Eager, thenEager, returnEager, mapEager, appEager, runEager,
-- general list processing
IF_NOT_GHC(forall COMMA exists COMMA)
@@ -30,7 +17,7 @@ module Util (
zipLazy,
mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith,
+ startsWith, endsWith, snocView,
isIn, isn'tIn,
-- association lists
@@ -52,23 +39,23 @@ module Util (
mapAccumL, mapAccumR, mapAccumB,
-- comparisons
- Ord3(..), thenCmp, cmpList,
- cmpPString, FAST_STRING,
+ thenCmp, cmpList,
+ FastString,
-- pairs
IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith
+ unzipWith,
-- error handling
- , panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
- , assertPanic, assertPprPanic
+ panic, panic#, assertPanic
) where
-CHK_Ubiq() -- debugging consistency check
-IMPORT_1_3(List(zipWith4))
-import Pretty
+#include "HsVersions.h"
+
+import FastString ( FastString )
+import List ( zipWith4 )
infixr 9 `thenCmp`
\end{code}
@@ -107,22 +94,6 @@ mapEager f (x:xs) = f x `thenEager` \ y ->
%************************************************************************
%* *
-\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell}
-%* *
-%************************************************************************
-
-This is our own idea:
-\begin{code}
-#ifndef __GLASGOW_HASKELL__
-data TAG_ = LT_ | EQ_ | GT_
-
-tagCmp_ :: Ord a => a -> a -> TAG_
-tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_
-#endif
-\end{code}
-
-%************************************************************************
-%* *
\subsection[Utils-lists]{General list processing}
%* *
%************************************************************************
@@ -232,7 +203,16 @@ endsWith cs ss
Just rs -> Just (reverse rs)
\end{code}
+\begin{code}
+snocView :: [a] -> ([a], a) -- Split off the last element
+snocView xs = go xs []
+ where
+ go [x] acc = (reverse acc, x)
+ go (x:xs) acc = go xs (x:acc)
+\end{code}
+
Debugging/specialising versions of \tr{elem} and \tr{notElem}
+
\begin{code}
isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
@@ -314,7 +294,7 @@ hasNoDups xs = f [] xs
\end{code}
\begin{code}
-equivClasses :: (a -> a -> TAG_) -- Comparison
+equivClasses :: (a -> a -> Ordering) -- Comparison
-> [a]
-> [[a]]
@@ -323,8 +303,8 @@ equivClasses cmp stuff@[item] = [stuff]
equivClasses cmp items
= runs eq (sortLt lt items)
where
- eq a b = case cmp a b of { EQ_ -> True; _ -> False }
- lt a b = case cmp a b of { LT_ -> True; _ -> False }
+ eq a b = case cmp a b of { EQ -> True; _ -> False }
+ lt a b = case cmp a b of { LT -> True; _ -> False }
\end{code}
The first cases in @equivClasses@ above are just to cut to the point
@@ -345,7 +325,7 @@ runs p (x:xs) = case (span (p x) xs) of
\end{code}
\begin{code}
-removeDups :: (a -> a -> TAG_) -- Comparison function
+removeDups :: (a -> a -> Ordering) -- Comparison function
-> [a]
-> ([a], -- List with no duplicates
[[a]]) -- List of duplicate groups. One representative from
@@ -361,6 +341,7 @@ removeDups cmp xs
collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
\end{code}
+
%************************************************************************
%* *
\subsection[Utils-sorting]{Sorting}
@@ -452,12 +433,12 @@ rqpart lt x (y:ys) rle rgt r =
%************************************************************************
\begin{code}
-mergesort :: (a -> a -> TAG_) -> [a] -> [a]
+mergesort :: (a -> a -> Ordering) -> [a] -> [a]
mergesort cmp xs = merge_lists (split_into_runs [] xs)
where
- a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
+ a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
split_into_runs [] [] = []
split_into_runs run [] = [run]
@@ -473,9 +454,9 @@ mergesort cmp xs = merge_lists (split_into_runs [] xs)
merge xs [] = xs
merge xl@(x:xs) yl@(y:ys)
= case cmp x y of
- EQ_ -> x : y : (merge xs ys)
- LT_ -> x : (merge xs yl)
- GT__ -> y : (merge xl ys)
+ EQ -> x : y : (merge xs ys)
+ LT -> x : (merge xs yl)
+ GT -> y : (merge xl ys)
\end{code}
%************************************************************************
@@ -676,68 +657,37 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys)
%* *
%************************************************************************
-See also @tagCmp_@ near the versions-compatibility section.
-
-The Ord3 class will be subsumed into Ord in Haskell 1.3.
-
\begin{code}
-class Ord3 a where
- cmp :: a -> a -> TAG_
-
-thenCmp :: TAG_ -> TAG_ -> TAG_
+thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
-thenCmp EQ_ any = any
+thenCmp EQ any = any
thenCmp other any = other
-cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_
+cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
-- `cmpList' uses a user-specified comparer
-cmpList cmp [] [] = EQ_
-cmpList cmp [] _ = LT_
-cmpList cmp _ [] = GT_
+cmpList cmp [] [] = EQ
+cmpList cmp [] _ = LT
+cmpList cmp _ [] = GT
cmpList cmp (a:as) (b:bs)
- = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx }
-\end{code}
-
-\begin{code}
-instance Ord3 a => Ord3 [a] where
- cmp [] [] = EQ_
- cmp (x:xs) [] = GT_
- cmp [] (y:ys) = LT_
- cmp (x:xs) (y:ys) = (x `cmp` y) `thenCmp` (xs `cmp` ys)
-
-instance Ord3 a => Ord3 (Maybe a) where
- cmp Nothing Nothing = EQ_
- cmp Nothing (Just y) = LT_
- cmp (Just x) Nothing = GT_
- cmp (Just x) (Just y) = x `cmp` y
-
-instance Ord3 Int where
- cmp a b | a < b = LT_
- | a > b = GT_
- | otherwise = EQ_
+ = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
\end{code}
\begin{code}
-cmpString :: String -> String -> TAG_
+cmpString :: String -> String -> Ordering
-cmpString [] [] = EQ_
+cmpString [] [] = EQ
cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
- else if x < y then LT_
- else GT_
-cmpString [] ys = LT_
-cmpString xs [] = GT_
+ else if x < y then LT
+ else GT
+cmpString [] ys = LT
+cmpString xs [] = GT
-cmpString _ _ = panic# "cmpString"
+cmpString _ _ = panic "cmpString"
\end{code}
-\begin{code}
-cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
-
-cmpPString x y
- = case (tagCmpFS x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
-\end{code}
+y
%************************************************************************
%* *
\subsection[Utils-pairs]{Pairs}
@@ -775,6 +725,7 @@ unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
\end{code}
+
%************************************************************************
%* *
\subsection[Utils-errors]{Error handling}
@@ -787,33 +738,13 @@ panic x = error ("panic! (the `impossible' happened):\n\t"
++ "Please report it as a compiler bug "
++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
-pprPanic heading pretty_msg = panic (heading++ " " ++ (show pretty_msg))
-pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
-# if __GLASGOW_HASKELL__ == 201
-pprTrace heading pretty_msg = GHCbase.trace (heading++" "++(show pretty_msg))
-# elif __GLASGOW_HASKELL__ >= 202
-pprTrace heading pretty_msg = GlaExts.trace (heading++" "++(show pretty_msg))
-# else
-pprTrace heading pretty_msg = trace (heading++" "++(show pretty_msg))
-# endif
-
-- #-versions because panic can't return an unboxed int, and that's
-- what TAG_ is with GHC at the moment. Ugh. (Simon)
-- No, man -- Too Beautiful! (Will)
-panic# :: String -> TAG_
-panic# s = case (panic s) of () -> EQ_
-
-pprPanic# heading pretty_msg = panic# (heading++(show pretty_msg))
+panic# :: String -> FAST_INT
+panic# s = case (panic s) of () -> ILIT(0)
assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-
-assertPprPanic :: String -> Int -> Doc -> a
-assertPprPanic file line msg
- = panic (show (sep [hsep[text "ASSERT failed! file",
- text file,
- text "line", int line],
- msg]))
-
+assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)
\end{code}
View Lorry Controller Status