#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); \
# -----------------------------------------------------------------------------
-# $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 = ..
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
# ----------------------------------------------------------------------------
# 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
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`
\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)))
)
= 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))
]
= 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}
import Outputable
import Binary
-import GlaExts
+import GLAEXTS
\end{code}
We hold both module names and identifier names in a 'Z-encoded' form
import FastString ( unpackFS )
import FastTypes
import FastString
-import GlaExts ( (+#) )
+
+import GLAEXTS ( (+#) )
\end{code}
%************************************************************************
#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
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}
%************************************************************************
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}
%************************************************************************
import FastTypes
import Outputable
-import IOExts ( IORef, newIORef, readIORef, writeIORef )
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
\end{code}
%
% (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}
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}
%************************************************************************
%
% (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}
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}
%************************************************************************
import Outputable
#endif
-import IOExts ( readIORef )
+import DATA_IOREF ( readIORef )
\end{code}
\begin{code}
) 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
import Exception ( block )
#endif
-import IOExts
+import DATA_IOREF ( IORef )
+
import List
import Monad
import IO
-#include "HsVersions.h"
-
-- ---------------------------------------------------------------------------
-- The Linker's state
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
-- 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
import Exception ( Exception, try )
#endif
--- lang
-import Exception ( throwDyn )
+import EXCEPTION ( throwDyn )
-- std
import Directory ( getModificationTime, doesFileExist )
import Util
#if __GLASGOW_HASKELL__ >= 404
-import GlaExts ( Int# )
+import GLAEXTS ( Int# )
#endif
\end{code}
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}
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}
%************************************************************************
{-# 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
--
import FieldLabel ( fieldLabelTyCon )
import SrcLoc ( isGoodSrcLoc )
import Module ( moduleName )
-import NameEnv ( nameEnvElts )
import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
NamedThing(..) )
import OccName ( isSymOcc )
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 )
+
-----------------------------------------------------------------------------
module BinIface ( writeBinIface ) where
+#include "HsVersions.h"
+
import HscTypes
import BasicTypes
import NewDemand
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 !-}
#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}
%************************************************************************
#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 )
import Pretty ( Mode(..), printDoc )
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
-import IOExts
+import DATA_IOREF ( readIORef )
+
import Monad ( when )
import IO
\end{code}
-----------------------------------------------------------------------------
--- $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
--
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
-----------------------------------------------------------------------------
--- $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
--
import Util ( global )
import Panic
-import IOExts
-import Exception
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import EXCEPTION
import Directory
import IO
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
--
-----------------------------------------------------------------------------
--- $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
--
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
-----------------------------------------------------------------------------
--- $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
--
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
import FastString
import Config
-import IOExts
+import DATA_IOREF ( readIORef )
+
import List
import Directory
import IO
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 )
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}
{-# 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
--
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:
) 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
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
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 "" = ""
import Outputable ( assertPanic )
-- DEBUGGING ONLY
---import IOExts ( trace )
+--import TRACE ( trace )
--import Outputable ( showSDoc )
--import MachOp ( pprMachOp )
#include "HsVersions.h"
#include "NCG.h"
-import List ( intersperse )
-
import MachMisc
import MachRegs
import MachCode
-- DEBUGGING ONLY
--import OrdList
+
+import List ( intersperse )
\end{code}
The 96/03 native-code generator has machine-independent and
import Stix ( pprStixStmt )
-- DEBUGGING ONLY
-import IOExts ( trace )
import Outputable ( assertPanic )
import FastString
+import TRACE ( trace )
infixr 3 `bind`
\end{code}
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}
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
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}
#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}
#include "HsVersions.h"
-import Ratio ( Rational )
-import IOExts ( unsafePerformIO )
-import IO ( hPutStrLn, stderr )
-
import AbsCSyn ( node, tagreg, MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import ForeignCall ( CCallConv )
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.
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).
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)
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
-- -----------------------
, 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
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}
%************************************************************************
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}
import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
import Name ( Name {-instance NamedThing-},
- nameModule, isInternalName, nameIsLocalOrFrom
+ nameModule, isInternalName
)
import NameEnv
import NameSet
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}
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_`
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(..) )
import GHC.Arr ( Array(..) )
#endif
+import Array ( array, (//) )
+
infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
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)
import SrcLoc ( SrcLoc )
import Outputable
-import IOExts ( newIORef )
+import DATA_IOREF ( newIORef )
\end{code}
%************************************************************************
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}
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-}
hPutFS, -- :: Handle -> FastString -> IO ()
LitString,
- mkLitString# -- :: Addr# -> Addr
+ mkLitString# -- :: Addr# -> LitString
) where
-- This #define suppresses the "import FastString" that
#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
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]
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# =
-- 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)
-- _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)
-- 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) $
-- _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) $
return v
)
where
- btm = error ""
-
bucket_match [] _ _ _ = Nothing
bucket_match (v:ls) start# len# ba# =
case v of
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
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}
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}
FastBool, fastBool, isFastTrue, fastOr
) where
+#include "HsVersions.h"
+
#if defined(__GLASGOW_HASKELL__)
-- Import the beggars
-import GlaExts
+import GLAEXTS
( Int(..), Int#, (+#), (-#), (*#),
quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#)
)
#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
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
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.
#include "HsVersions.h"
import FastString
-import GlaExts
-import Numeric (fromRat)
import PrimPacked ( strLength )
+
+import GLAEXTS
+
+import Numeric (fromRat)
import IO
#if __GLASGOW_HASKELL__ < 503
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
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
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
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,
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 ()
[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}
\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
#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
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
\begin{code}
instance Show StringBuffer where
- showsPrec _ s = showString ""
+ showsPrec _ s = showString "<stringbuffer>"
\end{code}
\begin{code}
-- 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}
-----------------------------------------------------------------------------
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
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 ->
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_ ->
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)
'\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#
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
"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
-- 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}
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}
%************************************************************************
%
-% (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,
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,
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
#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`
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
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}
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)
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
projects / ghc-hetmet.git / commitdiff