summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsimonmar <unknown>2002-08-29 15:44:23 +0000
committersimonmar <unknown>2002-08-29 15:44:23 +0000
commitce9687a5f450014c5596b32de8e8a7b99b6389e8 (patch)
tree718993a94d5e2b03bae392f4b3b4710814c3c4d8
parent4a851c8281491a26ce130e6ce4496042e3feb42b (diff)
downloadhaskell-ce9687a5f450014c5596b32de8e8a7b99b6389e8.tar.gz
[project @ 2002-08-29 15:44:11 by simonmar]
Housekeeping: - The main goal is to remove dependencies on hslibs for a bootstrapped compiler, leaving only a requirement that the packages base, haskell98 and readline are built in stage 1 in order to bootstrap. We're almost there: Posix is still required for signal handling, but all other dependencies on hslibs are now gone. Uses of Addr and ByteArray/MutableByteArray array are all gone from the compiler. PrimPacked defines the Ptr type for GHC 4.08 (which didn't have it), and it defines simple BA and MBA types to replace uses of ByteArray and MutableByteArray respectively. - Clean up import lists. HsVersions.h now defines macros for some modules which have moved between GHC versions. eg. one now imports 'GLAEXTS' to get at unboxed types and primops in the compiler. Many import lists have been sorted as per the recommendations in the new style guidelines in the commentary. I've built the compiler with GHC 4.08.2, 5.00.2, 5.02.3, 5.04 and itself, and everything still works here. Doubtless I've got something wrong, though.
-rw-r--r--ghc/compiler/HsVersions.h30
-rw-r--r--ghc/compiler/Makefile24
-rw-r--r--ghc/compiler/absCSyn/PprAbsC.lhs51
-rw-r--r--ghc/compiler/basicTypes/OccName.lhs2
-rw-r--r--ghc/compiler/basicTypes/SrcLoc.lhs3
-rw-r--r--ghc/compiler/basicTypes/UniqSupply.lhs7
-rw-r--r--ghc/compiler/basicTypes/Unique.lhs43
-rw-r--r--ghc/compiler/basicTypes/Var.lhs2
-rw-r--r--ghc/compiler/codeGen/CgHeapery.lhs5
-rw-r--r--ghc/compiler/codeGen/CgStackery.lhs10
-rw-r--r--ghc/compiler/codeGen/CodeGen.lhs2
-rw-r--r--ghc/compiler/compMan/CmLink.lhs18
-rw-r--r--ghc/compiler/compMan/CompManager.lhs3
-rw-r--r--ghc/compiler/coreSyn/CoreUnfold.lhs2
-rw-r--r--ghc/compiler/ghci/ByteCodeFFI.lhs5
-rw-r--r--ghc/compiler/ghci/ByteCodeLink.lhs6
-rw-r--r--ghc/compiler/ghci/InteractiveUI.hs35
-rw-r--r--ghc/compiler/main/BinIface.hs10
-rw-r--r--ghc/compiler/main/CmdLineOpts.lhs8
-rw-r--r--ghc/compiler/main/CodeOutput.lhs5
-rw-r--r--ghc/compiler/main/DriverFlags.hs8
-rw-r--r--ghc/compiler/main/DriverMkDepend.hs6
-rw-r--r--ghc/compiler/main/DriverPipeline.hs8
-rw-r--r--ghc/compiler/main/DriverState.hs7
-rw-r--r--ghc/compiler/main/DriverUtil.hs8
-rw-r--r--ghc/compiler/main/Finder.lhs3
-rw-r--r--ghc/compiler/main/HscMain.lhs12
-rw-r--r--ghc/compiler/main/Main.hs29
-rw-r--r--ghc/compiler/main/SysTools.lhs61
-rw-r--r--ghc/compiler/nativeGen/AbsCStixGen.lhs2
-rw-r--r--ghc/compiler/nativeGen/AsmCodeGen.lhs4
-rw-r--r--ghc/compiler/nativeGen/MachCode.lhs2
-rw-r--r--ghc/compiler/nativeGen/MachMisc.lhs5
-rw-r--r--ghc/compiler/nativeGen/PprMach.lhs117
-rw-r--r--ghc/compiler/nativeGen/Stix.lhs9
-rw-r--r--ghc/compiler/nativeGen/StixInfo.lhs4
-rw-r--r--ghc/compiler/ndpFlatten/Flattening.hs26
-rw-r--r--ghc/compiler/parser/Ctype.lhs10
-rw-r--r--ghc/compiler/parser/Lex.lhs6
-rw-r--r--ghc/compiler/prelude/PrelRules.lhs13
-rw-r--r--ghc/compiler/rename/RnHiFiles.lhs9
-rw-r--r--ghc/compiler/rename/RnMonad.lhs6
-rw-r--r--ghc/compiler/simplCore/SimplMonad.lhs18
-rw-r--r--ghc/compiler/typecheck/TcEnv.lhs2
-rw-r--r--ghc/compiler/typecheck/TcMonad.lhs7
-rw-r--r--ghc/compiler/utils/BitSet.lhs4
-rw-r--r--ghc/compiler/utils/FastString.lhs136
-rw-r--r--ghc/compiler/utils/FastTypes.lhs4
-rw-r--r--ghc/compiler/utils/FiniteMap.lhs3
-rw-r--r--ghc/compiler/utils/Outputable.lhs3
-rw-r--r--ghc/compiler/utils/Panic.lhs10
-rw-r--r--ghc/compiler/utils/Pretty.lhs21
-rw-r--r--ghc/compiler/utils/PrimPacked.lhs245
-rw-r--r--ghc/compiler/utils/StringBuffer.lhs104
-rw-r--r--ghc/compiler/utils/UniqFM.lhs3
-rw-r--r--ghc/compiler/utils/Util.lhs48
56 files changed, 712 insertions, 522 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h
index 40a58517b4..62c9c076a6 100644
--- a/ghc/compiler/HsVersions.h
+++ b/ghc/compiler/HsVersions.h
@@ -10,6 +10,36 @@ you will screw up the layout where they are used in case expressions!
#endif
+#if __GLASGOW_HASKELL__ >= 504
+
+#define CONCURRENT Control.Concurrent
+#define EXCEPTION Control.Exception
+#define DYNAMIC Data.Dynamic
+#define GLAEXTS GHC.Exts
+#define DATA_BITS Data.Bits
+#define DATA_INT Data.Int
+#define DATA_WORD Data.Word
+#define UNSAFE_IO System.IO.Unsafe
+#define TRACE Debug.Trace
+#define DATA_IOREF Data.IORef
+#define FIX_IO System.IO
+
+#else
+
+#define CONCURRENT Concurrent
+#define EXCEPTION Exception
+#define DYNAMIC Dynamic
+#define GLAEXTS GlaExts
+#define DATA_BITS Bits
+#define DATA_INT Int
+#define DATA_WORD Word
+#define UNSAFE_IO IOExts
+#define TRACE IOExts
+#define DATA_IOREF IOExts
+#define FIX_IO IOExts
+
+#endif
+
#ifdef __GLASGOW_HASKELL__
#define GLOBAL_VAR(name,value,ty) \
name = Util.global (value) :: IORef (ty); \
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index c4ce2a3d18..cc46148e75 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.219 2002/06/14 08:23:57 simonpj Exp $
+# $Id: Makefile,v 1.220 2002/08/29 15:44:12 simonmar Exp $
TOP = ..
@@ -232,14 +232,6 @@ ifeq "$(bootstrapped)" "YES"
utils/Binary_HC_OPTS = -funbox-strict-fields
endif
-# flags for PrimPacked:
-#
-# -monly-2-regs
-# because it contains 'ccall strlen' and 'ccall memcmp', which gets
-# inlined by gcc, causing a lack of registers.
-#
-utils/PrimPacked_HC_OPTS = -fvia-C
-
# ByteCodeItbls uses primops that the NCG doesn't support yet.
ghci/ByteCodeItbls_HC_OPTS = -fvia-C
ghci/ByteCodeLink_HC_OPTS = -fvia-C -monly-3-regs
@@ -368,10 +360,16 @@ endif
# ----------------------------------------------------------------------------
# profiling.
-rename/Rename_HC_OPTS += -auto-all
-rename/RnEnv_HC_OPTS += -auto-all
-rename/RnHiFiles_HC_OPTS += -auto-all
-rename/RnSource_HC_OPTS += -auto-all
+# rename/Rename_HC_OPTS += -auto-all
+# rename/RnEnv_HC_OPTS += -auto-all
+# rename/RnHiFiles_HC_OPTS += -auto-all
+# rename/RnIfaces_HC_OPTS += -auto-all
+# rename/RnSource_HC_OPTS += -auto-all
+# rename/RnBinds_HC_OPTS += -auto-all
+# rename/RnExpr_HC_OPTS += -auto-all
+# rename/RnHsSyn_HC_OPTS += -auto-all
+# rename/RnNames_HC_OPTS += -auto-all
+# rename/RnTypes_HC_OPTS += -auto-all
#-----------------------------------------------------------------------------
# clean
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 782c45bc8a..fff3006be1 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -58,10 +58,14 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet,
import StgSyn ( StgOp(..) )
import BitSet ( BitSet, intBS )
import Outputable
-import GlaExts
import FastString
import Util ( lengthExceeds, listLengthCmp )
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+
+import GLAEXTS
import ST
infixr 9 `thenTE`
@@ -1764,13 +1768,46 @@ can safely initialise to static locations.
\begin{code}
big_doubles = (getPrimRepSize DoubleRep) /= 1
--- floatss are always 1 word
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
+castFloatToIntArray = castSTUArray
+
+castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
+castDoubleToIntArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readIntArray :: STUArray s Int Int -> Int -> ST s Int
+readIntArray = readArray
+
+#else
+
+castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToIntArray = return
+
+castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castDoubleToIntArray = return
+
+#endif
+
+-- floats are always 1 word
floatToWord :: CAddrMode -> CAddrMode
floatToWord (CLit (MachFloat r))
= runST (do
arr <- newFloatArray ((0::Int),0)
writeFloatArray arr 0 (fromRational r)
- i <- readIntArray arr 0
+ arr' <- castFloatToIntArray arr
+ i <- readIntArray arr' 0
return (CLit (MachInt (toInteger i)))
)
@@ -1780,8 +1817,9 @@ doubleToWords (CLit (MachDouble r))
= runST (do
arr <- newDoubleArray ((0::Int),1)
writeDoubleArray arr 0 (fromRational r)
- i1 <- readIntArray arr 0
- i2 <- readIntArray arr 1
+ arr' <- castDoubleToIntArray arr
+ i1 <- readIntArray arr' 0
+ i2 <- readIntArray arr' 1
return [ CLit (MachInt (toInteger i1))
, CLit (MachInt (toInteger i2))
]
@@ -1790,7 +1828,8 @@ doubleToWords (CLit (MachDouble r))
= runST (do
arr <- newDoubleArray ((0::Int),0)
writeDoubleArray arr 0 (fromRational r)
- i <- readIntArray arr 0
+ arr' <- castDoubleToIntArray arr
+ i <- readIntArray arr' 0
return [ CLit (MachInt (toInteger i)) ]
)
\end{code}
diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index e10d43fc27..e2a4b8f816 100644
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -50,7 +50,7 @@ import FastString
import Outputable
import Binary
-import GlaExts
+import GLAEXTS
\end{code}
We hold both module names and identifier names in a 'Z-encoded' form
diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index c3fca1db64..e219b4c30c 100644
--- a/ghc/compiler/basicTypes/SrcLoc.lhs
+++ b/ghc/compiler/basicTypes/SrcLoc.lhs
@@ -31,7 +31,8 @@ import Outputable
import FastString ( unpackFS )
import FastTypes
import FastString
-import GlaExts ( (+#) )
+
+import GLAEXTS ( (+#) )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index 91f92eba8a..86cf320bf8 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -24,12 +24,9 @@ module UniqSupply (
#include "HsVersions.h"
import Unique
-import GlaExts
-#if __GLASGOW_HASKELL__ < 301
-import IOBase ( IO(..), IOResult(..) )
-#else
-#endif
+import GLAEXTS
+import UNSAFE_IO ( unsafeInterleaveIO )
w2i x = word2Int# x
i2w x = int2Word# x
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index d2f4d7aaae..eba88fbcc9 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -49,12 +49,12 @@ module Unique (
import BasicTypes ( Boxity(..) )
import FastString ( FastString, uniqueOfFS )
-import GlaExts
-import ST
-import Char ( chr, ord )
+import Outputable
import FastTypes
-import Outputable
+import GLAEXTS
+
+import Char ( chr, ord )
\end{code}
%************************************************************************
@@ -227,48 +227,21 @@ instance Show Unique where
A character-stingy way to read/write numbers (notably Uniques).
The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints.
Code stolen from Lennart.
-\begin{code}
-# define BYTE_ARRAY GlaExts.ByteArray
-# define RUN_ST ST.runST
-# define AND_THEN >>=
-# define AND_THEN_ >>
-# define RETURN return
+\begin{code}
iToBase62 :: Int -> SDoc
iToBase62 n@(I# n#)
= ASSERT(n >= 0)
- let
-#if __GLASGOW_HASKELL__ < 405
- bytes = case chars62 of { BYTE_ARRAY bounds_who_needs_'em bytes -> bytes }
-#else
- bytes = case chars62 of { BYTE_ARRAY _ _ bytes -> bytes }
-#endif
- in
if n# <# 62# then
- case (indexCharArray# bytes n#) of { c ->
+ case (indexCharOffAddr# chars62# n#) of { c ->
char (C# c) }
else
case (quotRem n 62) of { (q, I# r#) ->
- case (indexCharArray# bytes r#) of { c ->
+ case (indexCharOffAddr# chars62# r#) of { c ->
(<>) (iToBase62 q) (char (C# c)) }}
-
--- keep this at top level! (bug on 94/10/24 WDP)
-chars62 :: BYTE_ARRAY Int
-chars62
- = RUN_ST (
- newCharArray (0, 61) AND_THEN \ ch_array ->
- fill_in ch_array 0 62 "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
- AND_THEN_
- unsafeFreezeByteArray ch_array
- )
where
- fill_in ch_array i lim str
- | i == lim
- = RETURN ()
- | otherwise
- = writeCharArray ch_array i (str !! i) AND_THEN_
- fill_in ch_array (i+1) lim str
+ chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
\end{code}
%************************************************************************
diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs
index 8002471377..e317315bba 100644
--- a/ghc/compiler/basicTypes/Var.lhs
+++ b/ghc/compiler/basicTypes/Var.lhs
@@ -47,7 +47,7 @@ import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import FastTypes
import Outputable
-import IOExts ( IORef, newIORef, readIORef, writeIORef )
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
\end{code}
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index a040d32c00..3b3c403eaa 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.31 2002/04/29 14:03:41 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.32 2002/08/29 15:44:13 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
@@ -31,12 +31,13 @@ import ClosureInfo ( closureSize, closureGoodStuffSize,
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Unique )
import CmdLineOpts ( opt_GranMacros )
-import GlaExts
import Outputable
#ifdef DEBUG
import PprAbsC ( pprMagicId ) -- tmp
#endif
+
+import GLAEXTS
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index a75b7e7583..cae8586b7c 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.20 2001/10/03 13:57:42 simonmar Exp $
+% $Id: CgStackery.lhs,v 1.21 2002/08/29 15:44:13 simonmar Exp $
%
\section[CgStackery]{Stack management functions}
@@ -27,12 +27,10 @@ import AbsCUtils ( mkAbstractCs, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import Panic ( panic )
-import Constants ( uF_SIZE, pROF_UF_SIZE, gRAN_UF_SIZE,
- sEQ_FRAME_SIZE, pROF_SEQ_FRAME_SIZE,
- gRAN_SEQ_FRAME_SIZE )
-
+import Constants
import Util ( sortLt )
-import IOExts ( trace )
+
+import TRACE ( trace )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index a8ce811cf0..76aa521612 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -57,7 +57,7 @@ import Panic ( assertPanic )
import Outputable
#endif
-import IOExts ( readIORef )
+import DATA_IOREF ( readIORef )
\end{code}
\begin{code}
diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 962c052abc..86ea6db0b4 100644
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -20,19 +20,22 @@ module CmLink (
) where
+#include "HsVersions.h"
+
#ifdef GHCI
import ByteCodeLink ( linkIModules, linkIExpr )
+import Interpreter
+import Name ( Name )
+import FiniteMap
+import ErrUtils ( showPass )
+import DATA_IOREF ( readIORef, writeIORef )
#endif
-import Interpreter
import DriverPipeline
import CmTypes
import HscTypes ( GhciMode(..) )
-import Name ( Name )
import Module ( ModuleName )
-import FiniteMap
import Outputable
-import ErrUtils ( showPass )
import CmdLineOpts ( DynFlags(..) )
import Util
@@ -40,13 +43,12 @@ import Util
import Exception ( block )
#endif
-import IOExts
+import DATA_IOREF ( IORef )
+
import List
import Monad
import IO
-#include "HsVersions.h"
-
-- ---------------------------------------------------------------------------
-- The Linker's state
@@ -114,6 +116,7 @@ filterModuleLinkables p (li:lis)
dump = filterModuleLinkables p lis
retain = li : dump
+#ifdef GHCI
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
case findModuleLinkable_maybe objs_loaded (linkableModName l) of
@@ -122,7 +125,6 @@ linkableInSet l objs_loaded =
-- These two are used to add/remove entries from the closure env for
-- new bindings made at the prompt.
-#ifdef GHCI
delListFromClosureEnv :: PersistentLinkerState -> [Name]
-> IO PersistentLinkerState
delListFromClosureEnv pls names
diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 860f801ff9..0c7ead9f41 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -106,8 +106,7 @@ import CForeign
import Exception ( Exception, try )
#endif
--- lang
-import Exception ( throwDyn )
+import EXCEPTION ( throwDyn )
-- std
import Directory ( getModificationTime, doesFileExist )
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index a357f12e58..c20c22f1b2 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -59,7 +59,7 @@ import Outputable
import Util
#if __GLASGOW_HASKELL__ >= 404
-import GlaExts ( Int# )
+import GLAEXTS ( Int# )
#endif
\end{code}
diff --git a/ghc/compiler/ghci/ByteCodeFFI.lhs b/ghc/compiler/ghci/ByteCodeFFI.lhs
index 569e4f6ce5..5e81002648 100644
--- a/ghc/compiler/ghci/ByteCodeFFI.lhs
+++ b/ghc/compiler/ghci/ByteCodeFFI.lhs
@@ -17,9 +17,10 @@ import ForeignCall ( CCallConv(..) )
import Bits ( Bits(..), shiftR, shiftL )
import Foreign ( newArray )
-import Word ( Word8, Word32 )
+import Data.Word ( Word8, Word32 )
import Foreign ( Ptr, mallocBytes )
-import IOExts ( trace, unsafePerformIO )
+import Debug.Trace ( trace )
+import System.IO.Unsafe ( unsafePerformIO )
import IO ( hPutStrLn, stderr )
\end{code}
diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs
index eac4de0d47..9e1e8881aa 100644
--- a/ghc/compiler/ghci/ByteCodeLink.lhs
+++ b/ghc/compiler/ghci/ByteCodeLink.lhs
@@ -54,15 +54,9 @@ import Control.Exception ( throwDyn )
import GlaExts ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
-#if __GLASGOW_HASKELL__ >= 503
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..) )
-#else
-import PrelArr ( Array(..) )
-import PrelIOBase ( IO(..) )
-import Ptr ( Ptr(..) )
-#endif
\end{code}
%************************************************************************
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index ace5ed3476..48253687e7 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.131 2002/08/05 09:18:27 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.132 2002/08/29 15:44:14 simonmar Exp $
--
-- GHC Interactive User Interface
--
@@ -38,7 +38,6 @@ import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
import FieldLabel ( fieldLabelTyCon )
import SrcLoc ( isGoodSrcLoc )
import Module ( moduleName )
-import NameEnv ( nameEnvElts )
import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
NamedThing(..) )
import OccName ( isSymOcc )
@@ -53,28 +52,32 @@ import Config
import Posix
#endif
-import Exception
-import Dynamic
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
import Readline
#endif
-import Concurrent
-import IOExts
-import SystemExts
+
+--import SystemExts
+
+import Control.Exception as Exception
+import Data.Dynamic
+import Control.Concurrent
import Numeric
-import List
-import System
-import CPUTime
-import Directory
-import IO
-import Char
-import Monad
+import Data.List
+import System.Cmd
+import System.CPUTime
+import System.Environment
+import System.Directory
+import System.IO as IO
+import Data.Char
+import Control.Monad as Monad
-import GlaExts ( unsafeCoerce# )
+import GHC.Exts ( unsafeCoerce# )
import Foreign ( nullPtr )
-import CString ( CString, peekCString, withCString )
+import Foreign.C.String ( CString, peekCString, withCString )
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+
-----------------------------------------------------------------------------
diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs
index e9e1694698..cb8a5701df 100644
--- a/ghc/compiler/main/BinIface.hs
+++ b/ghc/compiler/main/BinIface.hs
@@ -7,6 +7,8 @@
module BinIface ( writeBinIface ) where
+#include "HsVersions.h"
+
import HscTypes
import BasicTypes
import NewDemand
@@ -28,14 +30,12 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
import StringBuffer ( hGetStringBuffer )
import Panic
import SrcLoc
-
import Binary
-import IOExts ( readIORef )
-import Monad ( when )
-import Exception ( throwDyn )
+import DATA_IOREF ( readIORef )
+import EXCEPTION ( throwDyn )
-#include "HsVersions.h"
+import Monad ( when )
-- BasicTypes
{-! for IPName derive: Binary !-}
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index fd17c53353..4dd726116b 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -117,15 +117,15 @@ module CmdLineOpts (
#include "HsVersions.h"
-import GlaExts
-import IOExts ( IORef, readIORef, writeIORef )
import Constants -- Default values for some flags
import Util
-import FastTypes
import FastString ( FastString, mkFastString )
import Config
-
import Maybes ( firstJust )
+
+import GLAEXTS
+import DATA_IOREF ( IORef, readIORef, writeIORef )
+import UNSAFE_IO ( unsafePerformIO )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 166c0990e6..15b9a9cc8c 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -20,13 +20,13 @@ import IlxGen ( ilxGen )
#ifdef JAVA
import JavaGen ( javaGen )
import qualified PrintJava
+import OccurAnal ( occurAnalyseBinds )
#endif
import DriverState ( v_HCHeader )
import TyCon ( TyCon )
import Id ( Id )
import CoreSyn ( CoreBind )
-import OccurAnal ( occurAnalyseBinds )
import StgSyn ( StgBinding )
import AbsCSyn ( AbstractC )
import PprAbsC ( dumpRealC, writeRealC )
@@ -37,7 +37,8 @@ import Outputable
import Pretty ( Mode(..), printDoc )
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
-import IOExts
+import DATA_IOREF ( readIORef )
+
import Monad ( when )
import IO
\end{code}
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index 5cd18390b8..7c6ebaa3a1 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.100 2002/08/02 12:24:04 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.101 2002/08/29 15:44:15 simonmar Exp $
--
-- Driver flags
--
@@ -27,10 +27,10 @@ import Config
import Util
import Panic
-import Exception
-import IOExts
-import System ( exitWith, ExitCode(..) )
+import EXCEPTION
+import DATA_IOREF ( readIORef, writeIORef )
+import System ( exitWith, ExitCode(..) )
import IO
import Maybe
import Monad
diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs
index 5d49e540a6..5035fec046 100644
--- a/ghc/compiler/main/DriverMkDepend.hs
+++ b/ghc/compiler/main/DriverMkDepend.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.20 2002/03/21 09:00:54 simonpj Exp $
+-- $Id: DriverMkDepend.hs,v 1.21 2002/08/29 15:44:15 simonmar Exp $
--
-- GHC Driver
--
@@ -22,8 +22,8 @@ import HscTypes ( ModuleLocation(..) )
import Util ( global )
import Panic
-import IOExts
-import Exception
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import EXCEPTION
import Directory
import IO
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index c2d4235186..bc75ba7e8d 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -48,20 +48,18 @@ import Maybes ( expectJust )
import ParserCoreUtils ( getCoreModuleName )
+import EXCEPTION
+import DATA_IOREF ( readIORef, writeIORef )
+
#ifdef GHCI
import Time ( getClockTime )
#endif
import Directory
import System
-import IOExts
-import Exception
-
import IO
import Monad
import Maybe
-import PackedString
-
-----------------------------------------------------------------------------
-- genPipeline
--
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index 1b4a06bdfa..845c8aac47 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.80 2002/06/12 22:04:26 wolfgang Exp $
+-- $Id: DriverState.hs,v 1.81 2002/08/29 15:44:15 simonmar Exp $
--
-- Settings for the driver
--
@@ -20,10 +20,11 @@ import DriverPhases
import DriverUtil
import Util
import Config
-import Exception
-import IOExts
import Panic
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import EXCEPTION
+
import List
import Char
import Monad
diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 92961ef096..367ae543e9 100644
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.32 2002/04/05 16:43:56 sof Exp $
+-- $Id: DriverUtil.hs,v 1.33 2002/08/29 15:44:15 simonmar Exp $
--
-- Utils for the driver
--
@@ -16,9 +16,9 @@ import Util
import Panic
import Config ( cLeadingUnderscore )
-import IOExts
-import Exception
-import Dynamic
+import EXCEPTION as Exception
+import DYNAMIC
+import DATA_IOREF ( IORef, readIORef, writeIORef )
import Directory ( getDirectoryContents, doesDirectoryExist )
import IO
diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index 082891e51d..a710609458 100644
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -26,7 +26,8 @@ import Module
import FastString
import Config
-import IOExts
+import DATA_IOREF ( readIORef )
+
import List
import Directory
import IO
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 747a14a8e0..cf6420054a 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -79,6 +79,9 @@ import Bag ( consBag, emptyBag )
import Outputable
import HscStats ( ppSourceStats )
import HscTypes
+import MkExternalCore ( emitExternalCore )
+import ParserCore
+import ParserCoreUtils
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
@@ -88,17 +91,12 @@ import FastString
import Maybes ( expectJust )
import Util ( seqList )
-import IOExts ( newIORef, readIORef, writeIORef,
- unsafePerformIO )
+import DATA_IOREF ( newIORef, readIORef, writeIORef )
+import UNSAFE_IO ( unsafePerformIO )
import Monad ( when )
import Maybe ( isJust, fromJust )
import IO
-
-import MkExternalCore ( emitExternalCore )
-import ParserCore
-import ParserCoreUtils
-
\end{code}
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index d4b80952f1..5687bfb709 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,7 +1,7 @@
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.108 2002/07/06 10:14:31 chak Exp $
+-- $Id: Main.hs,v 1.109 2002/08/29 15:44:15 simonmar Exp $
--
-- GHC Driver program
--
@@ -56,30 +56,31 @@ import Outputable
import Util
import Panic ( GhcException(..), panic )
--- Standard Haskell libraries
-import IO
-import Directory ( doesFileExist )
-import IOExts ( readIORef, writeIORef )
-import Exception ( throwDyn, Exception(..),
+import DATA_IOREF ( readIORef, writeIORef )
+import EXCEPTION ( throwDyn, Exception(..),
AsyncException(StackOverflow) )
-import System ( getArgs, exitWith, ExitCode(..) )
-import Monad
-import List
-import Maybe
#ifndef mingw32_HOST_OS
-import Concurrent ( myThreadId )
+import CONCURRENT ( myThreadId )
# if __GLASGOW_HASKELL__ < 500
-import Exception ( raiseInThread )
+import EXCEPTION ( raiseInThread )
#define throwTo raiseInThread
# else
-import Exception ( throwTo )
+import EXCEPTION ( throwTo )
# endif
import Posix ( Handler(Catch), installHandler, sigINT, sigQUIT )
-import Dynamic ( toDyn )
+import DYNAMIC ( toDyn )
#endif
+-- Standard Haskell libraries
+import IO
+import Directory ( doesFileExist )
+import System ( getArgs, exitWith, ExitCode(..) )
+import Monad
+import List
+import Maybe
+
-----------------------------------------------------------------------------
-- ToDo:
diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index 83d833cb27..8bdec9ac39 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -61,53 +61,57 @@ module SysTools (
) where
+#include "HsVersions.h"
+
import DriverUtil
import Config
import Outputable
import Panic ( progName, GhcException(..) )
-import Util ( global, dropList, notNull )
+import Util ( global, notNull )
import CmdLineOpts ( dynFlag, verbosity )
-import Exception ( throwDyn )
+import EXCEPTION ( throwDyn )
#if __GLASGOW_HASKELL__ > 408
-import qualified Exception ( catch )
+import qualified EXCEPTION as Exception ( catch )
#else
-import Exception ( catchAllIO )
+import EXCEPTION ( catchAllIO )
#endif
-import IO
-import Directory ( doesFileExist, removeFile )
-import IOExts ( IORef, readIORef, writeIORef )
+
+import DATA_IOREF ( IORef, readIORef, writeIORef )
+import DATA_INT
+
import Monad ( when, unless )
import System ( ExitCode(..), exitWith, getEnv, system )
-import CString
-import Int
-import Addr
-
+import IO
+import Directory ( doesFileExist, removeFile )
+
#include "../includes/config.h"
+-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
+-- lines on mingw32, so we disallow it now.
+#if defined(mingw32_HOST_OS) && (__GLASGOW_HASKELL__ <= 408)
+#error GHC <= 4.08 is not supported for bootstrapping GHC on i386-unknown-mingw32
+#endif
+
#ifndef mingw32_HOST_OS
import qualified Posix
#else
import List ( isPrefixOf )
+import Util ( dropList )
import MarshalArray
import Foreign
#endif
-#if __GLASGOW_HASKELL__ > 408
-# if __GLASGOW_HASKELL__ >= 503
-import GHC.IOBase
-# else
-# endif
-# ifdef mingw32_HOST_OS
+#ifdef mingw32_HOST_OS
+#if __GLASGOW_HASKELL__ > 504
+import System.Cmd ( rawSystem )
+#else
import SystemExts ( rawSystem )
-# endif
+#endif
#else
import System ( system )
#endif
-
-#include "HsVersions.h"
-
-- Make catch work on older GHCs
#if __GLASGOW_HASKELL__ > 408
myCatch = Exception.catch
@@ -836,14 +840,15 @@ slash s1 s2 = s1 ++ ('/' : s2)
getExecDir :: IO (Maybe String)
getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
buf <- mallocArray len
- ret <- getModuleFileName nullAddr buf len
+ ret <- getModuleFileName nullPtr buf len
if ret == 0 then free buf >> return Nothing
else do s <- peekCString buf
free buf
return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
-foreign import stdcall "GetModuleFileNameA" unsafe getModuleFileName :: Addr -> CString -> Int -> IO Int32
+foreign import stdcall "GetModuleFileNameA" unsafe
+ getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir :: IO (Maybe String) = do return Nothing
#endif
@@ -855,16 +860,6 @@ getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
-#if defined(mingw32_HOST_OS) && (__GLASGOW_HASKELL__ <= 408)
-rawSystem :: String -> IO ExitCode
-rawSystem cmd = system cmd
- -- mingw only: if you try to build a stage2 compiler with a stage1
- -- that has been bootstrapped with 4.08 (or earlier), this will run
- -- into problems with limits on command-line lengths with the std.
- -- Win32 command interpreters. So don't this - use 5.00 or later
- -- to compile up the GHC sources.
-#endif
-
quote :: String -> String
#if defined(mingw32_HOST_OS)
quote "" = ""
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 6a93c2b319..426ae3cb5f 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -49,7 +49,7 @@ import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
-- DEBUGGING ONLY
---import IOExts ( trace )
+--import TRACE ( trace )
--import Outputable ( showSDoc )
--import MachOp ( pprMachOp )
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index d3acf16413..5489238a96 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -8,8 +8,6 @@ module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
#include "NCG.h"
-import List ( intersperse )
-
import MachMisc
import MachRegs
import MachCode
@@ -39,6 +37,8 @@ import FastString
-- DEBUGGING ONLY
--import OrdList
+
+import List ( intersperse )
\end{code}
The 96/03 native-code generator has machine-independent and
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 737f1fa203..8ac49b8670 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -48,9 +48,9 @@ import CmdLineOpts ( opt_Static )
import Stix ( pprStixStmt )
-- DEBUGGING ONLY
-import IOExts ( trace )
import Outputable ( assertPanic )
import FastString
+import TRACE ( trace )
infixr 3 `bind`
\end{code}
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index ff45ff1bc6..70d7d06d49 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -53,13 +53,14 @@ import PrimRep ( PrimRep(..) )
import Stix ( StixStmt(..), StixExpr(..), StixReg(..),
CodeSegment, DestInfo(..) )
import Panic ( panic )
-import GlaExts
import Outputable ( pprPanic, ppr, showSDoc )
-import IOExts ( trace )
import Config ( cLeadingUnderscore )
import FastTypes
import FastString
+import GLAEXTS
+import TRACE ( trace )
+
import Maybe ( catMaybes )
\end{code}
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index b91597157e..6f75890700 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -22,13 +22,20 @@ import Stix ( CodeSegment(..) )
import Unique ( pprUnique )
import Panic ( panic )
import Pretty
+import FastString
import qualified Outputable
-import ST
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+import Data.Word ( Word8 )
+#else
import MutableArray
+#endif
+
+import ST
+
import Char ( chr, ord )
import Maybe ( isJust )
-import FastString
asmSDoc d = Outputable.withPprStyleDoc (
Outputable.mkCodeStyle Outputable.AsmStyle) d
@@ -478,38 +485,6 @@ pprInstr (DATA s xs)
in map (\b -> ptext SLIT("\t.byte\t") <> pprImm (ImmInt b)) bs
#endif
- -- floatToBytes and doubleToBytes convert to the host's byte
- -- order. Providing that we're not cross-compiling for a
- -- target with the opposite endianness, this should work ok
- -- on all targets.
- floatToBytes :: Float -> [Int]
- floatToBytes f
- = runST (do
- arr <- newFloatArray ((0::Int),3)
- writeFloatArray arr 0 f
- i0 <- readCharArray arr 0
- i1 <- readCharArray arr 1
- i2 <- readCharArray arr 2
- i3 <- readCharArray arr 3
- return (map ord [i0,i1,i2,i3])
- )
-
- doubleToBytes :: Double -> [Int]
- doubleToBytes d
- = runST (do
- arr <- newDoubleArray ((0::Int),7)
- writeDoubleArray arr 0 d
- i0 <- readCharArray arr 0
- i1 <- readCharArray arr 1
- i2 <- readCharArray arr 2
- i3 <- readCharArray arr 3
- i4 <- readCharArray arr 4
- i5 <- readCharArray arr 5
- i6 <- readCharArray arr 6
- i7 <- readCharArray arr 7
- return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
- )
-
-- fall through to rest of (machine-specific) pprInstr...
\end{code}
@@ -1758,3 +1733,77 @@ pp_comma_a = text ",a"
#endif {-sparc_TARGET_ARCH-}
\end{code}
+
+\begin{code}
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToCharArray :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToCharArray = castSTUArray
+
+castDoubleToCharArray :: STUArray s Int Double -> ST s (STUArray s Int Word8)
+castDoubleToCharArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readCharArray :: STUArray s Int Word8 -> Int -> ST s Char
+readCharArray arr i = do
+ w <- readArray arr i
+ return $! (chr (fromIntegral w))
+
+#else
+
+castFloatToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToCharArray = return
+
+castDoubleToCharArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castDoubleToCharArray = return
+
+#endif
+
+-- floatToBytes and doubleToBytes convert to the host's byte
+-- order. Providing that we're not cross-compiling for a
+-- target with the opposite endianness, this should work ok
+-- on all targets.
+
+-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
+-- could they be merged?
+
+floatToBytes :: Float -> [Int]
+floatToBytes f
+ = runST (do
+ arr <- newFloatArray ((0::Int),3)
+ writeFloatArray arr 0 f
+ arr <- castFloatToCharArray arr
+ i0 <- readCharArray arr 0
+ i1 <- readCharArray arr 1
+ i2 <- readCharArray arr 2
+ i3 <- readCharArray arr 3
+ return (map ord [i0,i1,i2,i3])
+ )
+
+doubleToBytes :: Double -> [Int]
+doubleToBytes d
+ = runST (do
+ arr <- newDoubleArray ((0::Int),7)
+ writeDoubleArray arr 0 d
+ arr <- castDoubleToCharArray arr
+ i0 <- readCharArray arr 0
+ i1 <- readCharArray arr 1
+ i2 <- readCharArray arr 2
+ i3 <- readCharArray arr 3
+ i4 <- readCharArray arr 4
+ i5 <- readCharArray arr 5
+ i6 <- readCharArray arr 6
+ i7 <- readCharArray arr 7
+ return (map ord [i0,i1,i2,i3,i4,i5,i6,i7])
+ )
+\end{code}
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 091107e9a2..930ff05221 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -32,10 +32,6 @@ module Stix (
#include "HsVersions.h"
-import Ratio ( Rational )
-import IOExts ( unsafePerformIO )
-import IO ( hPutStrLn, stderr )
-
import AbsCSyn ( node, tagreg, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import ForeignCall ( CCallConv )
@@ -50,6 +46,11 @@ import Constants ( wORD_SIZE )
import Outputable
import FastTypes
import FastString
+
+import UNSAFE_IO ( unsafePerformIO )
+
+import Ratio ( Rational )
+import IO ( hPutStrLn, stderr )
\end{code}
Two types, StixStmt and StixValue, define Stix.
diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs
index f9e24b9799..7dcae06d48 100644
--- a/ghc/compiler/nativeGen/StixInfo.lhs
+++ b/ghc/compiler/nativeGen/StixInfo.lhs
@@ -28,8 +28,8 @@ import UniqSupply ( returnUs, UniqSM )
import BitSet ( BitSet, intBS )
import Maybes ( maybeToBool )
-import Bits
-import Word
+import DATA_BITS
+import DATA_WORD
\end{code}
Generating code for info tables (arrays of data).
diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs
index 796d34e009..b8bf32dfe1 100644
--- a/ghc/compiler/ndpFlatten/Flattening.hs
+++ b/ghc/compiler/ndpFlatten/Flattening.hs
@@ -52,8 +52,15 @@ module Flattening (
flatten, flattenExpr,
) where
--- standard
-import Monad (liftM, foldM)
+#include "HsVersions.h"
+
+-- friends
+import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
+ isLit, mkPArrTy, mkTuple, isSimpleExpr, boolTy, substIdEnv)
+import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
+ liftVar, liftConst, intersectWithContext, mk'fst,
+ mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
+ mk'indexOfP,mk'eq,mk'neq)
-- GHC
import CmdLineOpts (opt_Flatten)
@@ -81,20 +88,11 @@ import BasicTypes (Boxity(..))
import Outputable (showSDoc, Outputable(..))
import FastString
--- friends
-import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
- isLit, mkPArrTy, mkTuple, isSimpleExpr, boolTy, substIdEnv)
-import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
- liftVar, liftConst, intersectWithContext, mk'fst,
- mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
- mk'indexOfP,mk'eq,mk'neq)
-
-- FIXME: fro debugging - remove this
-import IOExts (trace)
-
-
-#include "HsVersions.h"
+import TRACE (trace)
+-- standard
+import Monad (liftM, foldM)
-- toplevel transformation
-- -----------------------
diff --git a/ghc/compiler/parser/Ctype.lhs b/ghc/compiler/parser/Ctype.lhs
index 645f31ea61..405dc5c2b0 100644
--- a/ghc/compiler/parser/Ctype.lhs
+++ b/ghc/compiler/parser/Ctype.lhs
@@ -10,12 +10,12 @@ module Ctype
, is_upper -- Char# -> Bool
, is_digit -- Char# -> Bool
) where
-\end{code}
-\begin{code}
-import Bits ( Bits((.&.)) )
-import Int ( Int32 )
-import GlaExts ( Char#, Char(..) )
+#include "HsVersions.h"
+
+import DATA_INT ( Int32 )
+import DATA_BITS ( Bits((.&.)) )
+import GLAEXTS ( Char#, Char(..) )
\end{code}
Bit masks
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 57c68343a5..da7b16d6b5 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -47,11 +47,11 @@ import Outputable
import FastString
import StringBuffer
-import GlaExts
import Ctype
-import Bits ( Bits(..) ) -- non-std
-import Int ( Int32 )
+import GLAEXTS
+import DATA_BITS ( Bits(..) )
+import DATA_INT ( Int32 )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 62b8cfc72f..d7d4201eec 100644
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -41,15 +41,16 @@ import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
eqStringName, unpackCStringIdKey )
import Maybes ( orElse )
import Name ( Name )
-import Bits ( Bits(..) )
-#if __GLASGOW_HASKELL__ >= 500
-import Word ( Word )
-#else
-import Word ( Word64 )
-#endif
import Outputable
import FastString
import CmdLineOpts ( opt_SimplExcessPrecision )
+
+import DATA_BITS ( Bits(..) )
+#if __GLASGOW_HASKELL__ >= 500
+import DATA_WORD ( Word )
+#else
+import DATA_WORD ( Word64 )
+#endif
\end{code}
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 3bd71f9966..bd414fb83c 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -39,7 +39,7 @@ import RnMonad
import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
import Name ( Name {-instance NamedThing-},
- nameModule, isInternalName, nameIsLocalOrFrom
+ nameModule, isInternalName
)
import NameEnv
import NameSet
@@ -61,9 +61,10 @@ import qualified Binary
import Panic
import Config
-import IOExts
-import Exception
-import Dynamic ( fromDynamic )
+import EXCEPTION as Exception
+import DYNAMIC ( fromDynamic )
+import DATA_IOREF ( readIORef )
+
import Directory
import List ( isSuffixOf )
\end{code}
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 6fdcd33473..254b8eceac 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -68,8 +68,10 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
import Outputable
-import IOExts ( IORef, newIORef, readIORef, writeIORef,
- fixIO, unsafePerformIO )
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import UNSAFE_IO ( unsafePerformIO )
+import FIX_IO ( fixIO )
+
import IO ( hPutStr, stderr )
infixr 9 `thenRn`, `thenRn_`
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index f538bf9b75..fe43c6d347 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -80,12 +80,12 @@ import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
)
import Unique ( Unique )
-import Maybes ( expectJust )
import Outputable
-import Array ( array, (//) )
import FastTypes
-import GlaExts ( indexArray# )
import FastString
+import Maybes ( expectJust )
+
+import GLAEXTS ( indexArray# )
#if __GLASGOW_HASKELL__ < 503
import PrelArr ( Array(..) )
@@ -93,6 +93,8 @@ import PrelArr ( Array(..) )
import GHC.Arr ( Array(..) )
#endif
+import Array ( array, (//) )
+
infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
@@ -986,20 +988,10 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
defined_elems = map mk_assoc_elem tidied_on_switches
in
-- (avoid some unboxing, bounds checking, and other horrible things:)
-#if __GLASGOW_HASKELL__ < 405
- case sw_tbl of { Array bounds_who_needs_'em stuff ->
-#else
case sw_tbl of { Array _ _ stuff ->
-#endif
\ switch ->
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
-#if __GLASGOW_HASKELL__ < 400
- Lift v -> v
-#elif __GLASGOW_HASKELL__ < 403
- (# _, v #) -> v
-#else
(# v #) -> v
-#endif
}
where
mk_assoc_elem k@(MaxSimplifierIterations lvl)
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index f80e2dbca2..b1a9084060 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -70,7 +70,7 @@ import HscTypes ( lookupType, TyThing(..) )
import SrcLoc ( SrcLoc )
import Outputable
-import IOExts ( newIORef )
+import DATA_IOREF ( newIORef )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 7b06460ac9..a7c15f83f1 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -63,10 +63,9 @@ import Unique ( Unique )
import CmdLineOpts
import Outputable
-import IOExts ( IORef, newIORef, readIORef, writeIORef,
- unsafeInterleaveIO, fixIO
- )
-
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import UNSAFE_IO ( unsafeInterleaveIO )
+import FIX_IO ( fixIO )
infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs
index 071e166354..a108136af3 100644
--- a/ghc/compiler/utils/BitSet.lhs
+++ b/ghc/compiler/utils/BitSet.lhs
@@ -22,8 +22,10 @@ module BitSet (
unionBS, minusBS, intBS
) where
+#include "HsVersions.h"
+
#ifdef __GLASGOW_HASKELL__
-import GlaExts
+import GLAEXTS
-- nothing to import
#elif defined(__YALE_HASKELL__)
{-hide import from mkdependHS-}
diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 06a5c28f03..7523f92304 100644
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -38,7 +38,7 @@ module FastString
hPutFS, -- :: Handle -> FastString -> IO ()
LitString,
- mkLitString# -- :: Addr# -> Addr
+ mkLitString# -- :: Addr# -> LitString
) where
-- This #define suppresses the "import FastString" that
@@ -47,38 +47,36 @@ module FastString
#include "HsVersions.h"
#if __GLASGOW_HASKELL__ < 503
-import PrelPack
+import PrelPack hiding (packString)
import PrelIOBase ( IO(..) )
#else
-import CString
import GHC.IOBase ( IO(..) )
#endif
import PrimPacked
-import GlaExts
-#if __GLASGOW_HASKELL__ < 411
-import PrelAddr ( Addr(..) )
-#else
-import Addr ( Addr(..) )
-#endif
+import GLAEXTS
+import UNSAFE_IO ( unsafePerformIO )
+import ST ( stToIO )
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+
#if __GLASGOW_HASKELL__ < 503
import PrelArr ( STArray(..), newSTArray )
-import IOExts ( hPutBufBAFull )
#else
import GHC.Arr ( STArray(..), newSTArray )
-import IOExts ( hPutBufBA )
-import CString ( unpackNBytesBA# )
#endif
-import IOExts ( IORef, newIORef, readIORef, writeIORef )
+#if __GLASGOW_HASKELL__ >= 504
+import GHC.IOBase
+import GHC.Handle
+import Foreign.C
+#else
+import IOExts ( hPutBufBAFull )
+#endif
+
import IO
import Char ( chr, ord )
#define hASH_TBL_SIZE 993
-
-#if __GLASGOW_HASKELL__ < 503
-hPutBufBA = hPutBufBAFull
-#endif
\end{code}
@FastString@s are packed representations of strings
@@ -129,7 +127,7 @@ nullFastString (UnicodeStr _ []) = True
nullFastString (UnicodeStr _ (_:_)) = False
unpackFS :: FastString -> String
-unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
+unpackFS (FastString _ l# ba#) = unpackCStringBA (BA ba#) (I# l#)
unpackFS (UnicodeStr _ s) = map chr s
unpackIntFS :: FastString -> [Int]
@@ -213,7 +211,7 @@ updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
mkFastString# :: Addr# -> FastString
mkFastString# a# =
- case strLength (A# a#) of { (I# len#) -> mkFastStringLen# a# len# }
+ case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# }
mkFastStringLen# :: Addr# -> Int# -> FastString
mkFastStringLen# a# len# =
@@ -229,8 +227,8 @@ mkFastStringLen# a# len# =
-- 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#) ->
+ case copyPrefixStr a# (I# len#) of
+ BA barr# ->
let f_str = FastString uid# len# barr# in
updTbl string_table ft h [f_str] >>
({- _trace ("new: " ++ show f_str) $ -} return f_str)
@@ -240,8 +238,8 @@ mkFastStringLen# a# len# =
-- _trace ("non-empty bucket"++show ls) $
case bucket_match ls len# a# of
Nothing ->
- case copyPrefixStr (A# a#) (I# len#) of
- (ByteArray _ _ barr#) ->
+ case copyPrefixStr a# (I# len#) of
+ BA barr# ->
let f_str = FastString uid# len# barr# in
updTbl string_table ft h (f_str:ls) >>
( {- _trace ("new: " ++ show f_str) $ -} return f_str)
@@ -270,8 +268,8 @@ mkFastSubStringBA# barr# start# len# =
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket(b)" $
- case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
- (ByteArray _ _ ba#) ->
+ case copySubStrBA (BA barr#) (I# start#) (I# len#) of
+ BA ba# ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
@@ -282,8 +280,8 @@ mkFastSubStringBA# barr# start# len# =
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls start# len# barr# of
Nothing ->
- case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
- (ByteArray _ _ ba#) ->
+ case copySubStrBA (BA barr#) (I# start#) (I# len#) of
+ BA ba# ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
@@ -293,8 +291,6 @@ mkFastSubStringBA# barr# start# len# =
return v
)
where
- btm = error ""
-
bucket_match [] _ _ _ = Nothing
bucket_match (v:ls) start# len# ba# =
case v of
@@ -344,11 +340,11 @@ mkFastStringUnicode s =
mkFastStringNarrow :: String -> FastString
mkFastStringNarrow str =
- case packString str of
- (ByteArray _ (I# len#) frozen#) ->
+ case packString str of { (I# len#, BA frozen#) ->
mkFastSubStringBA# frozen# 0# len#
- {- 0-indexed array, len# == index to one beyond end of string,
- i.e., (0,1) => empty string. -}
+ }
+ {- 0-indexed array, len# == index to one beyond end of string,
+ i.e., (0,1) => empty string. -}
mkFastString :: String -> FastString
mkFastString str = if all good str
@@ -364,9 +360,9 @@ mkFastStringInt str = if all good str
where
good c = c >= 1 && c <= 0xFF
-mkFastSubString :: Addr -> Int -> Int -> FastString
-mkFastSubString (A# a#) (I# start#) (I# len#) =
- mkFastStringLen# (addrOffset# a# start#) len#
+mkFastSubString :: Addr# -> Int -> Int -> FastString
+mkFastSubString a# (I# start#) (I# len#) =
+ mkFastStringLen# (a# `plusAddr#` start#) len#
\end{code}
\begin{code}
@@ -428,41 +424,81 @@ cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars
EQ
else
unsafePerformIO (
- _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) ->
+ strcmp b1# b2# >>= \ (I# res) ->
return (
if res <# 0# then LT
else if res ==# 0# then EQ
else GT
))
- where
- bot :: Int
- bot = error "tagCmp"
-\end{code}
-Outputting @FastString@s is quick, just block copying the chunk (using
-@fwrite@).
+foreign import ccall "strcmp" unsafe
+ strcmp :: ByteArray# -> ByteArray# -> IO Int
+
+-- -----------------------------------------------------------------------------
+-- Outputting 'FastString's
+
+#if __GLASGOW_HASKELL__ >= 504
+
+-- this is our own version of hPutBuf for FastStrings, because in
+-- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA.
+-- The closest is hPutArray in Data.Array.IO, but that does some extra
+-- range checks that we want to avoid here.
+
+foreign import ccall unsafe "__hscore_memcpy_dst_off"
+ memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+
+hPutFS handle (FastString _ l# ba#)
+ | l# ==# 0# = return ()
+ | otherwise
+ = do wantWritableHandle "hPutFS" handle $
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
+
+ old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
+ <- readIORef ref
+
+ let count = I# l#
+ raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld
+
+ -- enough room in handle buffer?
+ if (size - w > count)
+ -- There's enough room in the buffer:
+ -- just copy the data in and update bufWPtr.
+ then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
+ writeIORef ref old_buf{ bufWPtr = w + count }
+ return ()
+
+ -- else, we have to flush
+ else do flushed_buf <- flushWriteBuffer fd stream old_buf
+ writeIORef ref flushed_buf
+ let this_buf =
+ Buffer{ bufBuf=raw, bufState=WriteBuffer,
+ bufRPtr=0, bufWPtr=count, bufSize=count }
+ flushWriteBuffer fd stream this_buf
+ return ()
+
+#else
-\begin{code}
hPutFS :: Handle -> FastString -> IO ()
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
| otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
- hPutBufBA handle mba (I# l#)
+ hPutBufBAFull handle mba (I# l#)
where
bot = error "hPutFS.ba"
+#endif
+
-- ONLY here for debugging the NCG (so -ddump-stix works for string
-- literals); no idea if this is really necessary. JRS, 010131
hPutFS handle (UnicodeStr _ is)
= hPutStr handle ("(UnicodeStr " ++ show is ++ ")")
-\end{code}
-Here for convenience only.
+-- -----------------------------------------------------------------------------
+-- LitStrings, here for convenience only.
-\begin{code}
-type LitString = Addr
+type LitString = Ptr ()
-- ToDo: make it a Ptr when we don't have to support 4.08 any more
mkLitString# :: Addr# -> LitString
-mkLitString# a# = A# a#
+mkLitString# a# = Ptr a#
\end{code}
diff --git a/ghc/compiler/utils/FastTypes.lhs b/ghc/compiler/utils/FastTypes.lhs
index e335848609..6accab1f8f 100644
--- a/ghc/compiler/utils/FastTypes.lhs
+++ b/ghc/compiler/utils/FastTypes.lhs
@@ -12,10 +12,12 @@ module FastTypes (
FastBool, fastBool, isFastTrue, fastOr
) where
+#include "HsVersions.h"
+
#if defined(__GLASGOW_HASKELL__)
-- Import the beggars
-import GlaExts
+import GLAEXTS
( Int(..), Int#, (+#), (-#), (*#),
quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#)
)
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 84212580f7..5e7e5c9191 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -57,12 +57,13 @@ module FiniteMap (
#define OUTPUTABLE_key {--}
#endif
-import GlaExts
import Maybes
import Bag ( Bag, foldrBag )
import Util
import Outputable
+import GLAEXTS
+
#if ! OMIT_NATIVE_CODEGEN
# define IF_NCG(a) a
#else
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index a23b44e38a..c837eb0321 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -56,7 +56,8 @@ import qualified Pretty
import Pretty ( Doc, Mode(..) )
import Panic
-import Word ( Word32 )
+import DATA_WORD ( Word32 )
+
import IO ( Handle, stderr, stdout, hFlush )
import Char ( chr )
#if __GLASGOW_HASKELL__ < 410
diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs
index e4c8cdaae9..fd6839bdc8 100644
--- a/ghc/compiler/utils/Panic.lhs
+++ b/ghc/compiler/utils/Panic.lhs
@@ -16,15 +16,17 @@ module Panic
showGhcException
) where
+#include "HsVersions.h"
+
import Config
import FastTypes
-import Dynamic
-import IOExts
-import Exception
+import DYNAMIC
+import EXCEPTION
+import TRACE ( trace )
+import UNSAFE_IO ( unsafePerformIO )
import System
-#include "HsVersions.h"
\end{code}
GHC's own exception type.
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index bf7f10b31f..6a1c07ffc3 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -178,9 +178,11 @@ module Pretty (
#include "HsVersions.h"
import FastString
-import GlaExts
-import Numeric (fromRat)
import PrimPacked ( strLength )
+
+import GLAEXTS
+
+import Numeric (fromRat)
import IO
#if __GLASGOW_HASKELL__ < 503
@@ -195,16 +197,7 @@ import PrelBase ( unpackCString# )
import GHC.Base ( unpackCString# )
#endif
-#if __GLASGOW_HASKELL__ < 411
-import PrelAddr ( Addr(..) )
-#else
-import Addr ( Addr(..) )
-#if __GLASGOW_HASKELL__ < 503
-import Ptr ( Ptr(..) )
-#else
-import GHC.Ptr ( Ptr(..) )
-#endif
-#endif
+import PrimPacked ( Ptr(..) )
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
@@ -608,12 +601,12 @@ isEmpty _ = False
char c = textBeside_ (Chr c) 1# Empty
text s = case length s of {IBOX(sl) -> textBeside_ (Str s) sl Empty}
ftext s = case lengthFS s of {IBOX(sl) -> textBeside_ (PStr s) sl Empty}
-ptext (A# s) = case strLength (A# s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
+ptext (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
-- intermediate packing/unpacking of the string.
{-# RULES
- "text/str" forall a. text (unpackCString# a) = ptext (A# a)
+ "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
#-}
nest IBOX(k) p = mkNest k (reduceDoc p) -- Externally callable version
diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs
index 9fa180795d..a0ee810706 100644
--- a/ghc/compiler/utils/PrimPacked.lhs
+++ b/ghc/compiler/utils/PrimPacked.lhs
@@ -8,33 +8,31 @@ of bytes (character strings). Used by the interface lexer input
subsystem, mostly.
\begin{code}
-{-# OPTIONS -monly-3-regs -optc-DNON_POSIX_SOURCE #-}
-module PrimPacked
- (
- strLength, -- :: _Addr -> Int
- copyPrefixStr, -- :: _Addr -> Int -> ByteArray Int
- copySubStr, -- :: _Addr -> Int -> Int -> ByteArray Int
- copySubStrBA, -- :: ByteArray Int -> Int -> Int -> ByteArray Int
-
- eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
- eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
- eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
- eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
-
- addrOffset# -- :: Addr# -> Int# -> Addr#
- ) where
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module PrimPacked (
+ Ptr(..), nullPtr, writeCharOffPtr, plusAddr#,
+ BA(..), MBA(..),
+ packString, -- :: String -> (Int, BA)
+ unpackCStringBA, -- :: BA -> Int -> [Char]
+ strLength, -- :: Ptr CChar -> Int
+ copyPrefixStr, -- :: Addr# -> Int -> BA
+ copySubStr, -- :: Addr# -> Int -> Int -> BA
+ copySubStrBA, -- :: BA -> Int -> Int -> BA
+ eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
+ eqCharStrPrefix, -- :: Addr# -> Addr# -> Int# -> Bool
+ eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
+ eqCharStrPrefixBA, -- :: Addr# -> ByteArray# -> Int# -> Int# -> Bool
+ ) where
-- This #define suppresses the "import FastString" that
-- HsVersions otherwise produces
#define COMPILING_FAST_STRING
#include "HsVersions.h"
-import GlaExts
-#if __GLASGOW_HASKELL__ < 411
-import PrelAddr ( Addr(..) )
-#else
-import Addr ( Addr(..) )
-#endif
+import GLAEXTS
+import UNSAFE_IO ( unsafePerformIO )
+
import ST
import Foreign
@@ -44,6 +42,85 @@ import PrelST
import GHC.ST
#endif
+#if __GLASGOW_HASKELL__ >= 504
+import GHC.Ptr ( Ptr(..) )
+#elif __GLASGOW_HASKELL__ >= 500
+import Ptr ( Ptr(..) )
+#endif
+
+#if __GLASGOW_HASKELL__ < 504
+import PrelIOBase ( IO(..) )
+#else
+import GHC.IOBase ( IO(..) )
+#endif
+\end{code}
+
+Compatibility: 4.08 didn't have the Ptr type.
+
+\begin{code}
+#if __GLASGOW_HASKELL__ <= 408
+data Ptr a = Ptr Addr# deriving (Eq, Ord)
+
+nullPtr :: Ptr a
+nullPtr = Ptr (int2Addr# 0#)
+#endif
+
+#if __GLASGOW_HASKELL__ <= 500
+-- plusAddr# is a primop in GHC > 5.00
+plusAddr# :: Addr# -> Int# -> Addr#
+plusAddr# a# i# = int2Addr# (addr2Int# a# +# i#)
+#endif
+
+-- more compatibility: in 5.00+ we would use the Storable class for this,
+-- but 4.08 doesn't have it.
+writeCharOffPtr (Ptr a#) (I# i#) (C# c#) = IO $ \s# ->
+ case writeCharOffAddr# a# i# c# s# of { s# -> (# s#, () #) }
+\end{code}
+
+Wrapper types for bytearrays
+
+\begin{code}
+data BA = BA ByteArray#
+data MBA s = MBA (MutableByteArray# s)
+\end{code}
+
+\begin{code}
+packString :: String -> (Int, BA)
+packString str = (l, arr)
+ where
+ l@(I# length#) = length str
+
+ arr = runST (do
+ ch_array <- new_ps_array (length# +# 1#)
+ -- fill in packed string from "str"
+ fill_in ch_array 0# str
+ -- freeze the puppy:
+ freeze_ps_array ch_array length#
+ )
+
+ fill_in :: MBA s -> Int# -> [Char] -> ST s ()
+ fill_in arr_in# idx [] =
+ write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+
+ fill_in arr_in# idx (C# c : cs) =
+ write_ps_array arr_in# idx c >>
+ fill_in arr_in# (idx +# 1#) cs
+\end{code}
+
+Unpacking a string
+
+\begin{code}
+unpackCStringBA :: BA -> Int -> [Char]
+unpackCStringBA (BA bytes) (I# len)
+ = unpack 0#
+ where
+ unpack nh
+ | nh >=# len ||
+ ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharArray# bytes nh
\end{code}
Copying a char string prefix into a byte array,
@@ -51,68 +128,59 @@ Copying a char string prefix into a byte array,
NULs.
\begin{code}
-copyPrefixStr :: Addr -> Int -> ByteArray Int
-copyPrefixStr (A# a) len@(I# length#) =
- runST (
- {- allocate an array that will hold the string
- (not forgetting the NUL at the end)
- -}
- (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# >>
- -- freeze the puppy:
- freeze_ps_array ch_array length# >>= \ barr ->
- return barr )
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
+copyPrefixStr :: Addr# -> Int -> BA
+copyPrefixStr a# len@(I# length#) = copy' length#
+ where
+ copy' length# = runST (do
+ {- allocate an array that will hold the string
+ (not forgetting the NUL at the end)
+ -}
+ ch_array <- new_ps_array (length# +# 1#)
+ {- 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#
+ -- freeze the puppy:
+ freeze_ps_array ch_array length#
+ )
+
+ fill_in :: MBA s -> Int# -> ST s ()
+ fill_in arr_in# idx
| idx ==# length#
= write_ps_array arr_in# idx (chr# 0#) >>
return ()
| otherwise
- = case (indexCharOffAddr# a idx) of { ch ->
+ = case (indexCharOffAddr# a# idx) of { ch ->
write_ps_array arr_in# idx ch >>
fill_in arr_in# (idx +# 1#) }
-
\end{code}
Copying out a substring, assume a 0-indexed string:
(and positive lengths, thank you).
\begin{code}
-copySubStr :: Addr -> Int -> Int -> ByteArray Int
-copySubStr a start length =
- unsafePerformIO (
- _casm_ `` %r= (char *)((char *)%0 + (int)%1); '' a start
- >>= \ a_start ->
- return (copyPrefixStr a_start length))
-
--- step on (char *) pointer by x units.
-addrOffset# :: Addr# -> Int# -> Addr#
-addrOffset# a# i# =
- 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#) =
- runST (
- {- allocate an array that will hold the string
- (not forgetting the NUL at the end)
- -}
- new_ps_array (length# +# 1#) >>= \ ch_array ->
- -- fill in packed string from "addr"
- fill_in ch_array 0# >>
- -- freeze the puppy:
- freeze_ps_array ch_array length#)
- where
- fill_in :: MutableByteArray s Int -> Int# -> ST s ()
-
- fill_in arr_in# idx
+copySubStr :: Addr# -> Int -> Int -> BA
+copySubStr a# (I# start#) length =
+ copyPrefixStr (a# `plusAddr#` start#) length
+
+copySubStrBA :: BA -> Int -> Int -> BA
+copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
+ where
+ ba = runST (do
+ {- allocate an array that will hold the string
+ (not forgetting the NUL at the end)
+ -}
+ ch_array <- new_ps_array (length# +# 1#)
+ -- fill in packed string from "addr"
+ fill_in ch_array 0#
+ -- freeze the puppy:
+ freeze_ps_array ch_array length#
+ )
+
+ fill_in :: MBA s -> Int# -> ST s ()
+ fill_in arr_in# idx
| idx ==# length#
= write_ps_array arr_in# idx (chr# 0#) >>
return ()
@@ -126,29 +194,28 @@ copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) =
[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 -> Int# -> ST s (ByteArray Int)
+new_ps_array :: Int# -> ST s (MBA s)
+write_ps_array :: MBA s -> Int# -> Char# -> ST s ()
+freeze_ps_array :: MBA s -> Int# -> ST s BA
-new_ps_array size = ST $ \ s ->
#if __GLASGOW_HASKELL__ < 411
- case (newCharArray# size s) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray bot bot barr# #) }
-#else /* 411 and higher */
- case (newByteArray# size s) of { (# s2#, barr# #) ->
- (# s2#, MutableByteArray bot bot barr# #) }
+#define NEW_BYTE_ARRAY newCharArray#
+#else
+#define NEW_BYTE_ARRAY newByteArray#
#endif
- where
- bot = error "new_ps_array"
-write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
+new_ps_array size = ST $ \ s ->
+ case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) ->
+ (# s2#, MBA barr# #) }
+
+write_ps_array (MBA barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
(# s2#, () #) }
-- same as unsafeFreezeByteArray
-freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
+freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
- (# s2#, ByteArray 0 (I# len#) frozen# #) }
+ (# s2#, BA frozen# #) }
\end{code}
@@ -182,8 +249,14 @@ eqCharStrPrefixBA a# b2# start# len# =
\end{code}
\begin{code}
+#if __GLASGOW_HASKELL__ <= 408
+strLength (Ptr a#) = ghc_strlen a#
+foreign import ccall "ghc_strlen" unsafe
+ ghc_strlen :: Addr# -> Int
+#else
foreign import ccall "ghc_strlen" unsafe
- strLength :: Addr -> Int
+ strLength :: Ptr () -> Int
+#endif
foreign import ccall "ghc_memcmp" unsafe
memcmp :: Addr# -> Addr# -> Int -> IO Int
diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index b51fd9d50f..b5737b7942 100644
--- a/ghc/compiler/utils/StringBuffer.lhs
+++ b/ghc/compiler/utils/StringBuffer.lhs
@@ -65,11 +65,9 @@ module StringBuffer
#include "HsVersions.h"
-#if __GLASGOW_HASKELL__ < 411
-import PrelAddr ( Addr(..) )
+#if __GLASGOW_HASKELL__ < 502
import Panic ( panic )
#else
-import Addr ( Addr(..) )
#if __GLASGOW_HASKELL__ < 503
import Ptr ( Ptr(..) )
#else
@@ -88,13 +86,16 @@ import GHC.IO ( hGetcBuffered )
import PrimPacked
import FastString
-import GlaExts
+import GLAEXTS
+
import Foreign
-import IO ( openFile, isEOFError )
-import Addr
-import Exception ( bracket )
-import CString ( unpackCStringBA )
+#if __GLASGOW_HASKELL__ >= 502
+import CForeign
+#endif
+
+import IO ( openFile, isEOFError )
+import EXCEPTION ( bracket )
#if __GLASGOW_HASKELL__ < 503
import PrelIOBase
@@ -118,7 +119,7 @@ data StringBuffer
\begin{code}
instance Show StringBuffer where
- showsPrec _ s = showString ""
+ showsPrec _ s = showString "<stringbuffer>"
\end{code}
\begin{code}
@@ -130,20 +131,14 @@ hGetStringBuffer fname = do
-- the sentinel. Assume it has a final newline for now, and overwrite
-- that with the sentinel. slurpFileExpandTabs (below) leaves room
-- for the sentinel.
- let (A# a#) = a;
+ let (Ptr a#) = a;
(I# read#) = read;
end# = read# -# 1#
- -- add sentinel '\NUL'
- _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' (A# a#) (I# end#)
- return (StringBuffer a# end# 0# 0#)
+ -- add sentinel '\NUL'
+ writeCharOffPtr a (I# end#) '\0'
-unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer
-unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
- unsafePerformIO (
- _casm_ `` ((char *)%0)[(int)%1]=(char)%2; '' (A# a) (I# i#) (C# ch#) >>= \ () ->
- return s
- )
+ return (StringBuffer a# end# 0# 0#)
\end{code}
-----------------------------------------------------------------------------
@@ -153,18 +148,11 @@ unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
stringToStringBuffer :: String -> IO StringBuffer
freeStringBuffer :: StringBuffer -> IO ()
-#if __GLASGOW_HASKELL__ >= 411
-stringToStringBuffer str =
- do let sz@(I# sz#) = length str
- (Ptr a#) <- mallocBytes (sz+1)
- fill_in str (A# a#)
- writeCharOffAddr (A# a#) sz '\0' -- sentinel
- return (StringBuffer a# sz# 0# 0#)
- where
- fill_in [] _ = return ()
- fill_in (c:cs) a = do
- writeCharOffAddr a 0 c
- fill_in cs (a `plusAddr` 1)
+#if __GLASGOW_HASKELL__ >= 502
+stringToStringBuffer str = do
+ let sz@(I# sz#) = length str
+ Ptr a# <- newCString str
+ return (StringBuffer a# sz# 0# 0#)
freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#)
#else
@@ -185,10 +173,12 @@ We guess the size of the buffer required as 20% extra for
expanded tabs, and enlarge it if necessary.
\begin{code}
+#if __GLASGOW_HASKELL__ < 501
getErrType :: IO Int
getErrType = _ccall_ getErrType__
+#endif
-slurpFileExpandTabs :: FilePath -> IO (Addr,Int)
+slurpFileExpandTabs :: FilePath -> IO (Ptr (),Int)
slurpFileExpandTabs fname = do
bracket (openFile fname ReadMode) (hClose)
(\ handle ->
@@ -200,14 +190,14 @@ slurpFileExpandTabs fname = do
if sz_i == 0
-- empty file: just allocate a buffer containing '\0'
then do chunk <- allocMem 1
- writeCharOffAddr chunk 0 '\0'
+ writeCharOffPtr chunk 0 '\0'
return (chunk, 0)
else do let sz_i' = (sz_i * 12) `div` 10 -- add 20% for tabs
chunk <- allocMem sz_i'
trySlurp handle sz_i' chunk
)
-trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int)
+trySlurp :: Handle -> Int -> Ptr () -> IO (Ptr (), Int)
trySlurp handle sz_i chunk =
#if __GLASGOW_HASKELL__ < 501
wantReadableHandle "hGetChar" handle $ \ handle_ ->
@@ -221,11 +211,11 @@ trySlurp handle sz_i chunk =
tAB_SIZE = 8#
- slurpFile :: Int# -> Int# -> Addr -> Int# -> Int# -> IO (Addr, Int)
+ slurpFile :: Int# -> Int# -> Ptr () -> Int# -> Int# -> IO (Ptr (), Int)
slurpFile c off chunk chunk_sz max_off = slurp c off
where
- slurp :: Int# -> Int# -> IO (Addr, Int)
+ slurp :: Int# -> Int# -> IO (Ptr (), Int)
slurp c off | off >=# max_off = do
let new_sz = chunk_sz *# 2#
chunk' <- reAllocMem chunk (I# new_sz)
@@ -257,16 +247,16 @@ trySlurp handle sz_i chunk =
'\xFFFF' -> return (chunk, I# off)
#endif
'\t' -> tabIt c off
- ch -> do writeCharOffAddr chunk (I# off) ch
+ ch -> do writeCharOffPtr chunk (I# off) ch
let c' | ch == '\n' = 0#
| otherwise = c +# 1#
slurp c' (off +# 1#)
- tabIt :: Int# -> Int# -> IO (Addr, Int)
+ tabIt :: Int# -> Int# -> IO (Ptr (), Int)
-- can't run out of buffer in here, because we reserved an
-- extra tAB_SIZE bytes at the end earlier.
tabIt c off = do
- writeCharOffAddr chunk (I# off) ' '
+ writeCharOffPtr chunk (I# off) ' '
let c' = c +# 1#
off' = off +# 1#
if c' `remInt#` tAB_SIZE ==# 0#
@@ -282,17 +272,17 @@ trySlurp handle sz_i chunk =
return (chunk', rc+1 {- room for sentinel -})
-reAllocMem :: Addr -> Int -> IO Addr
+reAllocMem :: Ptr () -> Int -> IO (Ptr ())
reAllocMem ptr sz = do
- chunk <- _ccall_ realloc ptr sz
- if chunk == nullAddr
+ chunk <- c_realloc ptr sz
+ if chunk == nullPtr
then fail "reAllocMem"
else return chunk
-allocMem :: Int -> IO Addr
+allocMem :: Int -> IO (Ptr ())
allocMem sz = do
- chunk <- _ccall_ malloc sz
- if chunk == nullAddr
+ chunk <- c_malloc sz
+ if chunk == nullPtr
#if __GLASGOW_HASKELL__ < 501
then constructErrorAndFail "allocMem"
#else
@@ -300,6 +290,22 @@ allocMem sz = do
"out of memory" Nothing)
#endif
else return chunk
+
+#if __GLASGOW_HASKELL__ <= 408
+c_malloc sz = do A# a <- c_malloc' sz; return (Ptr a)
+foreign import ccall "malloc" unsafe
+ c_malloc' :: Int -> IO Addr
+
+c_realloc (Ptr a) sz = do A# a <- c_realloc' (A# a) sz; return (Ptr a)
+foreign import ccall "realloc" unsafe
+ c_realloc' :: Addr -> Int -> IO Addr
+#else
+foreign import ccall "malloc" unsafe
+ c_malloc :: Int -> IO (Ptr a)
+
+foreign import ccall "realloc" unsafe
+ c_realloc :: Ptr a -> Int -> IO (Ptr a)
+#endif
\end{code}
Lookup
@@ -494,16 +500,18 @@ stepOnUntilChar# (StringBuffer fo l# s# c#) x# =
-- conversion
lexemeToString :: StringBuffer -> String
-lexemeToString (StringBuffer fo _ start_pos# current#) =
+lexemeToString (StringBuffer fo len# start_pos# current#) =
if start_pos# ==# current# then
""
else
- unpackCStringBA (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)))
+ unpackCStringBA
+ (copySubStr fo (I# start_pos#) (I# (current# -# start_pos#)))
+ (I# len#)
lexemeToFastString :: StringBuffer -> FastString
lexemeToFastString (StringBuffer fo l# start_pos# current#) =
if start_pos# ==# current# then
mkFastString ""
else
- mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#))
+ mkFastSubString fo (I# start_pos#) (I# (current# -# start_pos#))
\end{code}
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 7b27322dfd..6aa75b9dc9 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -50,9 +50,10 @@ import {-# SOURCE #-} Name ( Name )
import Unique ( Uniquable(..), Unique, getKey, mkUniqueGrimily )
import Panic
-import GlaExts -- Lots of Int# operations
import FastTypes
import Outputable
+
+import GLAEXTS -- Lots of Int# operations
\end{code}
%************************************************************************
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index a8d289de1c..d7b228e5c9 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -1,17 +1,10 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The University of Glasgow 1992-2002
%
\section[Util]{Highly random utility functions}
\begin{code}
--- IF_NOT_GHC is meant to make this module useful outside the context of GHC
-#define IF_NOT_GHC(a)
-
module Util (
-#if NOT_USED
- -- The Eager monad
- Eager, thenEager, returnEager, mapEager, appEager, runEager,
-#endif
-- general list processing
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
@@ -29,10 +22,7 @@ module Util (
nTimes,
-- sorting
- IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
- sortLt,
- IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
- IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
+ sortLt, naturalMergeSortLe,
-- transitive closures
transitiveClosure,
@@ -51,16 +41,12 @@ module Util (
foldl', seqList,
-- pairs
- IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
- IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith
+ unzipWith,
- , global
+ global,
#if __GLASGOW_HASKELL__ <= 408
- , catchJust
- , ioErrors
- , throwTo
+ catchJust, ioErrors, throwTo
#endif
) where
@@ -68,14 +54,19 @@ module Util (
#include "../includes/config.h"
#include "HsVersions.h"
-import qualified List ( elem, notElem )
-import List ( zipWith4 )
-import Maybe ( Maybe(..) )
import Panic ( panic, trace )
-import IOExts ( IORef, newIORef, unsafePerformIO )
import FastTypes
+
#if __GLASGOW_HASKELL__ <= 408
-import Exception ( catchIO, justIoErrors, raiseInThread )
+import EXCEPTION ( catchIO, justIoErrors, raiseInThread )
+#endif
+import DATA_IOREF ( IORef, newIORef )
+import UNSAFE_IO ( unsafePerformIO )
+
+import qualified List ( elem, notElem )
+
+#ifndef DEBUG
+import List ( zipWith4 )
#endif
infixr 9 `thenCmp`
@@ -359,8 +350,6 @@ Quicksort variant from Lennart's Haskell-library contribution. This
is a {\em stable} sort.
\begin{code}
-stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
-
sortLt :: (a -> a -> Bool) -- Less-than predicate
-> [a] -- Input list
-> [a] -- Result list
@@ -542,12 +531,15 @@ generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
generalNaturalMergeSort p [] = []
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
+#if NOT_USED
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
mergeSort = generalMergeSort (<=)
naturalMergeSort = generalNaturalMergeSort (<=)
mergeSortLe le = generalMergeSort le
+#endif
+
naturalMergeSortLe le = generalNaturalMergeSort le
\end{code}
@@ -751,14 +743,17 @@ suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
The following are curried versions of @fst@ and @snd@.
\begin{code}
+#if NOT_USED
cfst :: a -> b -> a -- stranal-sem only (Note)
cfst x y = x
+#endif
\end{code}
The following provide us higher order functions that, when applied
to a function, operate on pairs.
\begin{code}
+#if NOT_USED
applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
applyToPair (f,g) (x,y) = (f x, g y)
@@ -767,6 +762,7 @@ applyToFst f (x,y) = (f x,y)
applyToSnd :: (b -> d) -> (a,b) -> (a,d)
applyToSnd f (x,y) = (x,f y)
+#endif
foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
foldPair fg ab [] = ab