diff options
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 |