lots of portability changes (#1405)

re-recording to avoid new conflicts was too hard, so I just put it
all in one big patch :-(  (besides, some of the changes depended on
each other.)  Here are what the component patches were:

Fri Dec 28 11:02:55 EST 2007  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * document BreakArray better

Fri Dec 28 11:39:22 EST 2007  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * properly ifdef BreakArray for GHCI

Fri Jan  4 13:50:41 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * change ifs on __GLASGOW_HASKELL__ to account for... (#1405)
  for it not being defined. I assume it being undefined implies
  a compiler with relatively modern libraries but without most
  unportable glasgow extensions.

Fri Jan  4 14:21:21 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * MyEither-->EitherString to allow Haskell98 instance

Fri Jan  4 16:13:29 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * re-portabilize Pretty, and corresponding changes

Fri Jan  4 17:19:55 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * Augment FastTypes to be much more complete

Fri Jan  4 20:14:19 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * use FastFunctions, cleanup FastString slightly

Fri Jan  4 21:00:22 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * Massive de-"#", mostly Int# --> FastInt (#1405)

Fri Jan  4 21:02:49 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * miscellaneous unnecessary-extension-removal

Sat Jan  5 19:30:13 EST 2008  Isaac Dupree <id@isaac.cedarswampstudios.org>
  * add FastFunctions

diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
index add588d..dcab3c1 100644 (file)
--- a/compiler/HsVersions.h
+++ b/compiler/HsVersions.h
@@ -22,13 +22,15 @@ you will screw up the layout where they are used in case expressions!
  * settings for the target plat instead). */
 #include "../includes/ghcautoconf.h"
 
  * settings for the target plat instead). */
 #include "../includes/ghcautoconf.h"
 

-#if __GLASGOW_HASKELL__ >= 602
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 602

 #define SYSTEM_IO_ERROR System.IO.Error
 #else
 #define SYSTEM_IO_ERROR System.IO
 #endif
 
 #define SYSTEM_IO_ERROR System.IO.Error
 #else
 #define SYSTEM_IO_ERROR System.IO
 #endif
 

-#ifdef __GLASGOW_HASKELL__
+/* Global variables may not work in other Haskell implementations,
+ * but we need them currently! so the conditional on GLASGOW won't do. */
+#if defined(__GLASGOW_HASKELL__) || !defined(__GLASGOW_HASKELL__)

 #define GLOBAL_VAR(name,value,ty)  \
 name = Util.global (value) :: IORef (ty); \
 {-# NOINLINE name #-}
 #define GLOBAL_VAR(name,value,ty)  \
 name = Util.global (value) :: IORef (ty); \
 {-# NOINLINE name #-}

@@ -64,8 +66,13 @@ name = Util.global (value) :: IORef (ty); \
 import qualified FastString as FS 
 #endif
 
 import qualified FastString as FS 
 #endif
 

+#if defined(__GLASGOW_HASKELL__)

 #define SLIT(x)         (FS.mkLitString# (x#))
 #define FSLIT(x) (FS.mkFastString# (x#))
 #define SLIT(x)         (FS.mkLitString# (x#))
 #define FSLIT(x) (FS.mkFastString# (x#))

+#else
+#define SLIT(x)  (FS.mkLitString (x))
+#define FSLIT(x) (FS.mkFastString (x))
+#endif

 
 -- Useful for declaring arguments to be strict
 #define STRICT1(f) f a | a `seq` False = undefined
 
 -- Useful for declaring arguments to be strict
 #define STRICT1(f) f a | a `seq` False = undefined

diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs
index c6782f0..ec1d7c4 100644 (file)
--- a/compiler/basicTypes/Literal.lhs
+++ b/compiler/basicTypes/Literal.lhs
@@ -62,7 +62,7 @@ respectively (which will be wrong on a 64-bit machine).
 
 \begin{code}
 tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer
 
 \begin{code}
 tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer

-#if __GLASGOW_HASKELL__
+#ifdef __GLASGOW_HASKELL__

 tARGET_MIN_INT  = toInteger (minBound :: Int)
 tARGET_MAX_INT  = toInteger (maxBound :: Int)
 #else
 tARGET_MIN_INT  = toInteger (minBound :: Int)
 tARGET_MAX_INT  = toInteger (maxBound :: Int)
 #else

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index c6e7d25..489527e 100644 (file)
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -54,11 +54,11 @@ import Unique
 import Maybes
 import Binary
 import FastMutInt
 import Maybes
 import Binary
 import FastMutInt

+import FastTypes

 import FastString
 import Outputable
 
 import Data.IORef
 import FastString
 import Outputable
 
 import Data.IORef

-import GHC.Exts

 import Data.Array
 \end{code}
 
 import Data.Array
 \end{code}
 

@@ -72,7 +72,8 @@ import Data.Array
 data Name = Name {
                n_sort :: NameSort,     -- What sort of name it is
                n_occ  :: !OccName,     -- Its occurrence name
 data Name = Name {
                n_sort :: NameSort,     -- What sort of name it is
                n_occ  :: !OccName,     -- Its occurrence name

-               n_uniq :: Int#,         -- UNPACK doesn't work, recursive type
+               n_uniq :: FastInt,      -- UNPACK doesn't work, recursive type
+--(note later when changing Int# -> FastInt: is that still true about UNPACK?)

                n_loc  :: !SrcSpan      -- Definition site
            }
 
                n_loc  :: !SrcSpan      -- Definition site
            }
 

@@ -136,7 +137,7 @@ nameModule          :: Name -> Module
 nameSrcLoc             :: Name -> SrcLoc
 nameSrcSpan            :: Name -> SrcSpan
 
 nameSrcLoc             :: Name -> SrcLoc
 nameSrcSpan            :: Name -> SrcSpan
 

-nameUnique  name = mkUniqueGrimily (I# (n_uniq name))
+nameUnique  name = mkUniqueGrimily (iBox (n_uniq name))

 nameOccName name = n_occ  name
 nameSrcLoc  name = srcSpanStart (n_loc name)
 nameSrcSpan name = n_loc  name
 nameOccName name = n_occ  name
 nameSrcLoc  name = srcSpanStart (n_loc name)
 nameSrcSpan name = n_loc  name

@@ -193,7 +194,7 @@ isSystemName other                = False
 
 \begin{code}
 mkInternalName :: Unique -> OccName -> SrcSpan -> Name
 
 \begin{code}
 mkInternalName :: Unique -> OccName -> SrcSpan -> Name

-mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n_occ = occ, n_loc = loc }
+mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, n_occ = occ, n_loc = loc }

        -- NB: You might worry that after lots of huffing and
        -- puffing we might end up with two local names with distinct
        -- uniques, but the same OccName.  Indeed we can, but that's ok
        -- NB: You might worry that after lots of huffing and
        -- puffing we might end up with two local names with distinct
        -- uniques, but the same OccName.  Indeed we can, but that's ok

@@ -205,18 +206,18 @@ mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n
 
 mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
 mkExternalName uniq mod occ loc 
 
 mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
 mkExternalName uniq mod occ loc 

-  = Name { n_uniq = getKey# uniq, n_sort = External mod,
+  = Name { n_uniq = getKeyFastInt uniq, n_sort = External mod,

            n_occ = occ, n_loc = loc }
 
 mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax
         -> Name
 mkWiredInName mod occ uniq thing built_in
            n_occ = occ, n_loc = loc }
 
 mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax
         -> Name
 mkWiredInName mod occ uniq thing built_in

-  = Name { n_uniq = getKey# uniq,
+  = Name { n_uniq = getKeyFastInt uniq,

           n_sort = WiredIn mod thing built_in,
           n_occ = occ, n_loc = wiredInSrcSpan }
 
 mkSystemName :: Unique -> OccName -> Name
           n_sort = WiredIn mod thing built_in,
           n_occ = occ, n_loc = wiredInSrcSpan }
 
 mkSystemName :: Unique -> OccName -> Name

-mkSystemName uniq occ = Name { n_uniq = getKey# uniq, n_sort = System, 
+mkSystemName uniq occ = Name { n_uniq = getKeyFastInt uniq, n_sort = System, 

                               n_occ = occ, n_loc = noSrcSpan }
 
 mkSystemVarName :: Unique -> FastString -> Name
                               n_occ = occ, n_loc = noSrcSpan }
 
 mkSystemVarName :: Unique -> FastString -> Name

@@ -227,17 +228,17 @@ mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs)
 
 mkFCallName :: Unique -> String -> Name
        -- The encoded string completely describes the ccall
 
 mkFCallName :: Unique -> String -> Name
        -- The encoded string completely describes the ccall

-mkFCallName uniq str =  Name { n_uniq = getKey# uniq, n_sort = Internal, 
+mkFCallName uniq str =  Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, 

                               n_occ = mkVarOcc str, n_loc = noSrcSpan }
 
 mkTickBoxOpName :: Unique -> String -> Name
 mkTickBoxOpName uniq str 
                               n_occ = mkVarOcc str, n_loc = noSrcSpan }
 
 mkTickBoxOpName :: Unique -> String -> Name
 mkTickBoxOpName uniq str 

-   = Name { n_uniq = getKey# uniq, n_sort = Internal, 
+   = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, 

            n_occ = mkVarOcc str, n_loc = noSrcSpan }
 
 mkIPName :: Unique -> OccName -> Name
 mkIPName uniq occ
            n_occ = mkVarOcc str, n_loc = noSrcSpan }
 
 mkIPName :: Unique -> OccName -> Name
 mkIPName uniq occ

-  = Name { n_uniq = getKey# uniq,
+  = Name { n_uniq = getKeyFastInt uniq,

           n_sort = Internal,
           n_occ  = occ,
           n_loc = noSrcSpan }
           n_sort = Internal,
           n_occ  = occ,
           n_loc = noSrcSpan }

@@ -248,7 +249,7 @@ mkIPName uniq occ
 -- able to change a Name's Unique to match the cached
 -- one in the thing it's the name of.  If you know what I mean.
 setNameUnique :: Name -> Unique -> Name
 -- able to change a Name's Unique to match the cached
 -- one in the thing it's the name of.  If you know what I mean.
 setNameUnique :: Name -> Unique -> Name

-setNameUnique name uniq = name {n_uniq = getKey# uniq}
+setNameUnique name uniq = name {n_uniq = getKeyFastInt uniq}

 
 tidyNameOcc :: Name -> OccName -> Name
 -- We set the OccName of a Name when tidying
 
 tidyNameOcc :: Name -> OccName -> Name
 -- We set the OccName of a Name when tidying

@@ -284,7 +285,7 @@ hashName name = getKey (nameUnique name) + 1
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-cmpName n1 n2 = I# (n_uniq n1) `compare` I# (n_uniq n2)
+cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -347,14 +348,14 @@ instance Outputable Name where
 instance OutputableBndr Name where
     pprBndr _ name = pprName name
 
 instance OutputableBndr Name where
     pprBndr _ name = pprName name
 

-pprName name@(Name {n_sort = sort, n_uniq = u#, n_occ = occ})
+pprName name@(Name {n_sort = sort, n_uniq = u, n_occ = occ})

   = getPprStyle $ \ sty ->
     case sort of
       WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin
       External mod           -> pprExternal sty uniq mod occ False UserSyntax
       System                         -> pprSystem sty uniq occ
       Internal               -> pprInternal sty uniq occ
   = getPprStyle $ \ sty ->
     case sort of
       WiredIn mod _ builtin   -> pprExternal sty uniq mod occ True  builtin
       External mod           -> pprExternal sty uniq mod occ False UserSyntax
       System                         -> pprSystem sty uniq occ
       Internal               -> pprInternal sty uniq occ

-  where uniq = mkUniqueGrimily (I# u#)
+  where uniq = mkUniqueGrimily (iBox u)

 
 pprExternal sty uniq mod occ is_wired is_builtin
   | codeStyle sty        = ppr mod <> char '_' <> ppr_z_occ_name occ
 
 pprExternal sty uniq mod occ is_wired is_builtin
   | codeStyle sty        = ppr mod <> char '_' <> ppr_z_occ_name occ

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index d597a46..8298f59 100644 (file)
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -82,6 +82,7 @@ import StaticFlags
 import UniqFM
 import UniqSet
 import FastString
 import UniqFM
 import UniqSet
 import FastString

+import FastTypes

 import Outputable
 import Binary
 
 import Outputable
 import Binary
 

@@ -89,7 +90,7 @@ import GHC.Exts
 import Data.Char
 
 -- Unicode TODO: put isSymbol in libcompat
 import Data.Char
 
 -- Unicode TODO: put isSymbol in libcompat

-#if __GLASGOW_HASKELL__ > 604
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604

 #else
 isSymbol = const False
 #endif
 #else
 isSymbol = const False
 #endif

@@ -255,7 +256,7 @@ easy to build an OccEnv.
 \begin{code}
 instance Uniquable OccName where
   getUnique (OccName ns fs)
 \begin{code}
 instance Uniquable OccName where
   getUnique (OccName ns fs)

-      = mkUnique char (I# (uniqueOfFS fs))
+      = mkUnique char (iBox (uniqueOfFS fs))

       where    -- See notes above about this getUnique function
         char = case ns of
                VarName   -> 'i'
       where    -- See notes above about this getUnique function
         char = case ns of
                VarName   -> 'i'

diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs
index c228eeb..d28372a 100644 (file)
--- a/compiler/basicTypes/UniqSupply.lhs
+++ b/compiler/basicTypes/UniqSupply.lhs
@@ -31,20 +31,16 @@ module UniqSupply (
 #include "HsVersions.h"
 
 import Unique
 #include "HsVersions.h"
 
 import Unique

-
-import GHC.Exts
-import System.IO.Unsafe        ( unsafeInterleaveIO )
+import FastTypes

 
 #if __GLASGOW_HASKELL__ >= 607
 import GHC.IOBase (unsafeDupableInterleaveIO)
 #else
 
 #if __GLASGOW_HASKELL__ >= 607
 import GHC.IOBase (unsafeDupableInterleaveIO)
 #else

+import System.IO.Unsafe        ( unsafeInterleaveIO )

 unsafeDupableInterleaveIO :: IO a -> IO a
 unsafeDupableInterleaveIO = unsafeInterleaveIO
 #endif
 
 unsafeDupableInterleaveIO :: IO a -> IO a
 unsafeDupableInterleaveIO = unsafeInterleaveIO
 #endif
 

-w2i x = word2Int# x
-i2w x = int2Word# x
-i2w_s x = (x :: Int#)

 \end{code}
 
 
 \end{code}
 
 

@@ -61,7 +57,7 @@ which will be distinct from the first and from all others.
 
 \begin{code}
 data UniqSupply
 
 \begin{code}
 data UniqSupply

-  = MkSplitUniqSupply Int#     -- make the Unique with this
+  = MkSplitUniqSupply FastInt  -- make the Unique with this

                   UniqSupply UniqSupply
                                -- when split => these two supplies
 \end{code}
                   UniqSupply UniqSupply
                                -- when split => these two supplies
 \end{code}

@@ -76,21 +72,21 @@ uniqsFromSupply :: UniqSupply -> [Unique]   -- Infinite
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-mkSplitUniqSupply (C# c#)
-  = let
-       mask# = (i2w (ord# c#)) `uncheckedShiftL#` (i2w_s 24#)
+mkSplitUniqSupply c
+  = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of
+     mask -> let

        -- here comes THE MAGIC:
 
        -- This is one of the most hammered bits in the whole compiler
        -- here comes THE MAGIC:
 
        -- This is one of the most hammered bits in the whole compiler

-       mk_supply#
+       mk_supply

          = unsafeDupableInterleaveIO (
          = unsafeDupableInterleaveIO (

-               genSymZh    >>= \ (I# u#) ->
-               mk_supply#  >>= \ s1 ->
-               mk_supply#  >>= \ s2 ->
-               return (MkSplitUniqSupply (w2i (mask# `or#` (i2w u#))) s1 s2)
-           )
-    in
-    mk_supply#
+               genSymZh    >>= \ u_ -> case iUnbox u_ of { u -> (
+               mk_supply   >>= \ s1 ->
+               mk_supply   >>= \ s2 ->
+               return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2)
+           )})
+       in
+       mk_supply

 
 foreign import ccall unsafe "genSymZh" genSymZh :: IO Int
 
 
 foreign import ccall unsafe "genSymZh" genSymZh :: IO Int
 

@@ -99,8 +95,8 @@ listSplitUniqSupply  (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily (I# n)
-uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (I# n) : uniqsFromSupply s2
+uniqFromSupply  (MkSplitUniqSupply n _ _)  = mkUniqueGrimily (iBox n)
+uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs
index 5f9f668..ee21a0d 100644 (file)
--- a/compiler/basicTypes/Unique.lhs
+++ b/compiler/basicTypes/Unique.lhs
@@ -30,7 +30,7 @@ module Unique (
 
        mkUnique,                       -- Used in UniqSupply
        mkUniqueGrimily,                -- Used in UniqSupply only!
 
        mkUnique,                       -- Used in UniqSupply
        mkUniqueGrimily,                -- Used in UniqSupply only!

-       getKey, getKey#,                -- Used in Var, UniqFM, Name only!
+       getKey, getKeyFastInt,          -- Used in Var, UniqFM, Name only!

 
        incrUnique,                     -- Used for renumbering
        deriveUnique,                   -- Ditto
 
        incrUnique,                     -- Used for renumbering
        deriveUnique,                   -- Ditto

@@ -59,10 +59,16 @@ module Unique (
 
 import StaticFlags
 import BasicTypes
 
 import StaticFlags
 import BasicTypes

+import FastTypes

 import FastString
 import Outputable
 
 import FastString
 import Outputable
 

-import GHC.Exts
+#if defined(__GLASGOW_HASKELL__)
+--just for implementing a fast [0,61) -> Char function
+import GHC.Exts (indexCharOffAddr#, Char(..))
+#else
+import Data.Array
+#endif

 import Data.Char       ( chr, ord )
 \end{code}
 
 import Data.Char       ( chr, ord )
 \end{code}
 

@@ -76,7 +82,8 @@ The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.
 Fast comparison is everything on @Uniques@:
 
 \begin{code}
 Fast comparison is everything on @Uniques@:
 
 \begin{code}

-data Unique = MkUnique Int#
+--why not newtype Int?
+data Unique = MkUnique FastInt

 \end{code}
 
 Now come the functions which construct uniques from their pieces, and vice versa.
 \end{code}
 
 Now come the functions which construct uniques from their pieces, and vice versa.

@@ -88,7 +95,7 @@ unpkUnique    :: Unique -> (Char, Int)        -- The reverse
 
 mkUniqueGrimily :: Int -> Unique               -- A trap-door for UniqSupply
 getKey         :: Unique -> Int                -- for Var
 
 mkUniqueGrimily :: Int -> Unique               -- A trap-door for UniqSupply
 getKey         :: Unique -> Int                -- for Var

-getKey#                :: Unique -> Int#               -- for Var
+getKeyFastInt  :: Unique -> FastInt            -- for Var

 
 incrUnique     :: Unique -> Unique
 deriveUnique   :: Unique -> Int -> Unique
 
 incrUnique     :: Unique -> Unique
 deriveUnique   :: Unique -> Int -> Unique

@@ -99,18 +106,18 @@ isTupleKey :: Unique -> Bool
 
 
 \begin{code}
 
 
 \begin{code}

-mkUniqueGrimily (I# x) = MkUnique x
+mkUniqueGrimily x = MkUnique (iUnbox x)

 
 {-# INLINE getKey #-}
 
 {-# INLINE getKey #-}

-getKey (MkUnique x) = I# x
-{-# INLINE getKey# #-}
-getKey# (MkUnique x) = x
+getKey (MkUnique x) = iBox x
+{-# INLINE getKeyFastInt #-}
+getKeyFastInt (MkUnique x) = x

 
 

-incrUnique (MkUnique i) = MkUnique (i +# 1#)
+incrUnique (MkUnique i) = MkUnique (i +# _ILIT(1))

 
 -- deriveUnique uses an 'X' tag so that it won't clash with
 -- any of the uniques produced any other way
 
 -- deriveUnique uses an 'X' tag so that it won't clash with
 -- any of the uniques produced any other way

-deriveUnique (MkUnique i) delta = mkUnique 'X' (I# i + delta)
+deriveUnique (MkUnique i) delta = mkUnique 'X' (iBox i + delta)

 
 -- newTagUnique changes the "domain" of a unique to a different char
 newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
 
 -- newTagUnique changes the "domain" of a unique to a different char
 newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u

@@ -119,20 +126,20 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
 
 -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
 
 
 -- No 64-bit bugs here, as long as we have at least 32 bits. --JSM
 

-w2i x = word2Int# x
-i2w x = int2Word# x
-i2w_s x = (x::Int#)
+-- and as long as the Char fits in 8 bits, which we assume anyway!

 
 

-mkUnique (C# c) (I# i)
-  = MkUnique (w2i (tag `or#` bits))
+mkUnique c i
+  = MkUnique (tag `bitOrFastInt` bits)

   where
   where

-    tag  = i2w (ord# c) `uncheckedShiftL#` i2w_s 24#
-    bits = i2w i `and#` (i2w 16777215#){-``0x00ffffff''-}
+    tag  = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24)
+    bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-}

 
 unpkUnique (MkUnique u)
   = let
 
 unpkUnique (MkUnique u)
   = let

-       tag = C# (chr# (w2i ((i2w u) `uncheckedShiftRL#` (i2w_s 24#))))
-       i   = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
+       -- as long as the Char may have its eighth bit set, we
+       -- really do need the logical right-shift here!
+       tag = cBox (fastChr (u `shiftRLFastInt` _ILIT(24)))
+       i   = iBox (u `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-})

     in
     (tag, i)
 \end{code}
     in
     (tag, i)
 \end{code}

@@ -153,7 +160,7 @@ hasKey              :: Uniquable a => a -> Unique -> Bool
 x `hasKey` k   = getUnique x == k
 
 instance Uniquable FastString where
 x `hasKey` k   = getUnique x == k
 
 instance Uniquable FastString where

- getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs))
+ getUnique fs = mkUniqueGrimily (iBox (uniqueOfFS fs))

 
 instance Uniquable Int where
  getUnique i = mkUniqueGrimily i
 
 instance Uniquable Int where
  getUnique i = mkUniqueGrimily i

@@ -238,17 +245,28 @@ Code stolen from Lennart.
 
 \begin{code}
 iToBase62 :: Int -> String
 
 \begin{code}
 iToBase62 :: Int -> String

-iToBase62 n@(I# n#) 
-  = ASSERT(n >= 0) go n# ""
+iToBase62 n_
+  = ASSERT(n_ >= 0) go (iUnbox n_) ""

   where
   where

-    go n# cs | n# <# 62# 
-            = case (indexCharOffAddr# chars62# n#) of { c# -> C# c# : cs }
+    go n cs | n <# _ILIT(62)
+            = case chooseChar62 n of { c -> c `seq` (c : cs) }

             | otherwise
             | otherwise

-            =  case (quotRem (I# n#) 62)            of { (I# q#, I# r#) ->
-               case (indexCharOffAddr# chars62# r#) of { c#  ->
-               go q# (C# c# : cs) }}
-
-    chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
+            =  case (quotRem (iBox n) 62) of { (q_, r_) ->
+                case iUnbox q_ of { q -> case iUnbox r_ of { r ->
+               case (chooseChar62 r) of { c -> c `seq`
+               (go q (c : cs)) }}}}
+
+    chooseChar62 :: FastInt -> Char
+    {-# INLINE chooseChar62 #-}
+#if defined(__GLASGOW_HASKELL__)
+    --then FastInt == Int#
+    chooseChar62 n = C# (indexCharOffAddr# chars62 n)
+    chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
+#else
+    --Haskell98 arrays are portable
+    chooseChar62 n = (!) chars62 n
+    chars62 = listArray (0,61) "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+#endif

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index e66286e..5b3097d 100644 (file)
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -166,12 +166,12 @@ varUnique var = mkUniqueGrimily (iBox (realUnique var))
 
 setVarUnique :: Var -> Unique -> Var
 setVarUnique var uniq 
 
 setVarUnique :: Var -> Unique -> Var
 setVarUnique var uniq 

-  = var { realUnique = getKey# uniq, 
+  = var { realUnique = getKeyFastInt uniq, 

          varName = setNameUnique (varName var) uniq }
 
 setVarName :: Var -> Name -> Var
 setVarName var new_name
          varName = setNameUnique (varName var) uniq }
 
 setVarName :: Var -> Name -> Var
 setVarName var new_name

-  = var { realUnique = getKey# (getUnique new_name), 
+  = var { realUnique = getKeyFastInt (getUnique new_name), 

          varName = new_name }
 \end{code}
 
          varName = new_name }
 \end{code}
 

@@ -199,7 +199,7 @@ setTyVarKind tv k = tv {varType = k}
 mkTyVar :: Name -> Kind -> TyVar
 mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
                    TyVar { varName    = name
 mkTyVar :: Name -> Kind -> TyVar
 mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
                    TyVar { varName    = name

-                         , realUnique = getKey# (nameUnique name)
+                         , realUnique = getKeyFastInt (nameUnique name)

                          , varType  = kind
                           , isCoercionVar    = False
                        }
                          , varType  = kind
                           , isCoercionVar    = False
                        }

@@ -209,7 +209,7 @@ mkTcTyVar name kind details
   = -- TOM: no longer valid assertion? 
     -- ASSERT( not (isCoercionKind kind) )
     TcTyVar {  varName    = name,
   = -- TOM: no longer valid assertion? 
     -- ASSERT( not (isCoercionKind kind) )
     TcTyVar {  varName    = name,

-               realUnique = getKey# (nameUnique name),
+               realUnique = getKeyFastInt (nameUnique name),

                varType  = kind,
                tcTyVarDetails = details
        }
                varType  = kind,
                tcTyVarDetails = details
        }

@@ -232,7 +232,7 @@ setCoVarName   = setVarName
 mkCoVar :: Name -> Kind -> CoVar
 mkCoVar name kind = ASSERT( isCoercionKind kind )
                    TyVar { varName       = name
 mkCoVar :: Name -> Kind -> CoVar
 mkCoVar name kind = ASSERT( isCoercionKind kind )
                    TyVar { varName       = name

-                         , realUnique    = getKey# (nameUnique name)
+                         , realUnique    = getKeyFastInt (nameUnique name)

                          , varType       = kind        
                                -- varType is always PredTy (EqPred t1 t2)
                           , isCoercionVar = True
                          , varType       = kind        
                                -- varType is always PredTy (EqPred t1 t2)
                           , isCoercionVar = True

@@ -330,7 +330,7 @@ maybeModifyIdInfo Nothing     id = id
 mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
 mkGlobalId details name ty info 
   = GlobalId { varName    = name, 
 mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
 mkGlobalId details name ty info 
   = GlobalId { varName    = name, 

-               realUnique = getKey# (nameUnique name),         -- Cache the unique
+               realUnique = getKeyFastInt (nameUnique name),   -- Cache the unique

                varType     = ty,       
                gblDetails = details,
                idInfo_    = info }
                varType     = ty,       
                gblDetails = details,
                idInfo_    = info }

@@ -338,7 +338,7 @@ mkGlobalId details name ty info
 mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id
 mk_local_id name ty details info
   = LocalId {  varName    = name, 
 mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id
 mk_local_id name ty details info
   = LocalId {  varName    = name, 

-               realUnique = getKey# (nameUnique name),         -- Cache the unique
+               realUnique = getKeyFastInt (nameUnique name),   -- Cache the unique

                varType     = ty,       
                lclDetails = details,
                idInfo_    = info }
                varType     = ty,       
                lclDetails = details,
                idInfo_    = info }

diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index f3a093a..d65ec5f 100644 (file)
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -72,16 +72,16 @@ instance Outputable InScopeSet where
   ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
 
 emptyInScopeSet :: InScopeSet
   ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s
 
 emptyInScopeSet :: InScopeSet

-emptyInScopeSet = InScope emptyVarSet 1#
+emptyInScopeSet = InScope emptyVarSet (_ILIT(1))

 
 getInScopeVars ::  InScopeSet -> VarEnv Var
 getInScopeVars (InScope vs _) = vs
 
 mkInScopeSet :: VarEnv Var -> InScopeSet
 
 getInScopeVars ::  InScopeSet -> VarEnv Var
 getInScopeVars (InScope vs _) = vs
 
 mkInScopeSet :: VarEnv Var -> InScopeSet

-mkInScopeSet in_scope = InScope in_scope 1#
+mkInScopeSet in_scope = InScope in_scope (_ILIT(1))

 
 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
 
 extendInScopeSet :: InScopeSet -> Var -> InScopeSet

-extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
+extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1))

 
 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
 extendInScopeSetList (InScope in_scope n) vs
 
 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
 extendInScopeSetList (InScope in_scope n) vs

@@ -95,7 +95,7 @@ extendInScopeSetSet (InScope in_scope n) vs
 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
 -- Exploit the fact that the in-scope "set" is really a map
 --     Make old_v map to new_v
 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
 -- Exploit the fact that the in-scope "set" is really a map
 --     Make old_v map to new_v

-modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
+modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# _ILIT(1))

 
 delInScopeSet :: InScopeSet -> Var -> InScopeSet
 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
 
 delInScopeSet :: InScopeSet -> Var -> InScopeSet
 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n

@@ -134,17 +134,17 @@ uniqAway in_scope var
 uniqAway' :: InScopeSet -> Var -> Var
 -- This one *always* makes up a new variable
 uniqAway' (InScope set n) var
 uniqAway' :: InScopeSet -> Var -> Var
 -- This one *always* makes up a new variable
 uniqAway' (InScope set n) var

-  = try 1#
+  = try (_ILIT(1))

   where
     orig_unique = getUnique var
     try k 
 #ifdef DEBUG
   where
     orig_unique = getUnique var
     try k 
 #ifdef DEBUG

-         | k ># 1000#
+         | k ># _ILIT(1000)

          = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
 #endif                     
          = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
 #endif                     

-         | uniq `elemVarSetByKey` set = try (k +# 1#)
+         | uniq `elemVarSetByKey` set = try (k +# _ILIT(1))

 #ifdef DEBUG
 #ifdef DEBUG

-         | opt_PprStyle_Debug && k ># 3#
+         | opt_PprStyle_Debug && k ># _ILIT(3)

          = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
            setVarUnique var uniq
 #endif                     
          = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) 
            setVarUnique var uniq
 #endif                     

diff --git a/compiler/cbits/rawSystem.c b/compiler/cbits/rawSystem.c
index d103f48..3ef37e5 100644 (file)
--- a/compiler/cbits/rawSystem.c
+++ b/compiler/cbits/rawSystem.c
@@ -1,6 +1,6 @@
 /* Grab rawSystem from the library sources iff we're bootstrapping with an
  * old version of GHC.
  */
 /* Grab rawSystem from the library sources iff we're bootstrapping with an
  * old version of GHC.
  */

-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601

 #include "../../libraries/base/cbits/rawSystem.c"
 #endif
 #include "../../libraries/base/cbits/rawSystem.c"
 #endif

diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index c906050..a6cf27f 100644 (file)
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -30,13 +30,12 @@ import StaticFlags
 
 import UniqFM
 import Unique
 
 import UniqFM
 import Unique

-
+import FastTypes

 import Outputable
 
 import Data.Bits
 import Data.Word
 import Data.Int
 import Outputable
 
 import Data.Bits
 import Data.Word
 import Data.Int

-import GHC.Exts

 
 -- -----------------------------------------------------------------------------
 -- The mini-inliner
 
 -- -----------------------------------------------------------------------------
 -- The mini-inliner

@@ -463,23 +462,26 @@ cmmMachOpFold mop args = CmmMachOp mop args
 -- Used to be in MachInstrs --SDM.
 -- ToDo: remove use of unboxery --SDM.
 
 -- Used to be in MachInstrs --SDM.
 -- ToDo: remove use of unboxery --SDM.
 

-w2i x = word2Int# x
-i2w x = int2Word# x
+-- Unboxery removed in favor of FastInt; but is the function supposed to fail
+-- on inputs >= 2147483648, or was that just an implementation artifact?
+-- And is this speed-critical, or can we just use Integer operations
+-- (including Data.Bits)?
+--  --Isaac Dupree

 
 exactLog2 :: Integer -> Maybe Integer
 
 exactLog2 :: Integer -> Maybe Integer

-exactLog2 x
-  = if (x <= 0 || x >= 2147483648) then
+exactLog2 x_
+  = if (x_ <= 0 || x_ >= 2147483648) then

        Nothing
     else
        Nothing
     else

-       case fromInteger x of { I# x# ->
-       if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
+       case iUnbox (fromInteger x_) of { x ->
+       if (x `bitAndFastInt` negateFastInt x) /=# x then

          Nothing
        else
          Nothing
        else

-         Just (toInteger (I# (pow2 x#)))
+         Just (toInteger (iBox (pow2 x)))

        }
   where
        }
   where

-    pow2 x# | x# ==# 1# = 0#
-            | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
+    pow2 x | x ==# _ILIT(1) = _ILIT(0)
+           | otherwise = _ILIT(1) +# pow2 (x `shiftR_FastInt` _ILIT(1))

 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------

diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs
index 49f8b05..6e05cdc 100644 (file)
--- a/compiler/cmm/OptimizationFuel.hs
+++ b/compiler/cmm/OptimizationFuel.hs
@@ -11,7 +11,7 @@ module OptimizationFuel
     )
 where
 
     )
 where
 

-import GHC.Exts (State#)
+--import GHC.Exts (State#)

 import Panic
 
 import Data.IORef
 import Panic
 
 import Data.IORef

@@ -49,7 +49,7 @@ diffFuel _ _ = 0
 #endif
 
 -- stop warnings about things that aren't used
 #endif
 
 -- stop warnings about things that aren't used

-_unused :: State# () -> FS.FastString
+_unused :: {-State#-} () -> FS.FastString

 _unused = undefined panic
 
 
 _unused = undefined panic
 
 

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 9d71b73..9617c59 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -57,7 +57,6 @@ import Bag
 import FastTypes
 import Outputable
 
 import FastTypes
 import Outputable
 

-import GHC.Exts                ( Int# )

 \end{code}
 
 
 \end{code}
 
 

@@ -182,7 +181,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-sizeExpr :: Int#           -- Bomb out if it gets bigger than this
+sizeExpr :: FastInt        -- Bomb out if it gets bigger than this

         -> [Id]            -- Arguments; we're interested in which of these
                            -- get case'd
         -> CoreExpr
         -> [Id]            -- Arguments; we're interested in which of these
                            -- get case'd
         -> CoreExpr

@@ -242,7 +241,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
            case alts of
 
 
            case alts of
 

-               [alt] -> size_up_alt alt `addSize` SizeIs 0# (unitBag (v, 1)) 0#
+               [alt] -> size_up_alt alt `addSize` SizeIs (_ILIT(0)) (unitBag (v, 1)) (_ILIT(0))

                -- We want to make wrapper-style evaluation look cheap, so that
                -- when we inline a wrapper it doesn't make call site (much) bigger
                -- Otherwise we get nasty phase ordering stuff: 
                -- We want to make wrapper-style evaluation look cheap, so that
                -- when we inline a wrapper it doesn't make call site (much) bigger
                -- Otherwise we get nasty phase ordering stuff: 

@@ -270,7 +269,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
                -- the case when we are scrutinising an argument variable
          alts_size (SizeIs tot tot_disc tot_scrut)             -- Size of all alternatives
                    (SizeIs max max_disc max_scrut)             -- Size of biggest alternative
                -- the case when we are scrutinising an argument variable
          alts_size (SizeIs tot tot_disc tot_scrut)             -- Size of all alternatives
                    (SizeIs max max_disc max_scrut)             -- Size of biggest alternative

-               = SizeIs tot (unitBag (v, iBox (_ILIT 1 +# tot -# max)) `unionBags` max_disc) max_scrut
+               = SizeIs tot (unitBag (v, iBox (_ILIT(1) +# tot -# max)) `unionBags` max_disc) max_scrut

                        -- If the variable is known, we produce a discount that
                        -- will take us back to 'max', the size of rh largest alternative
                        -- The 1+ is a little discount for reduced allocation in the caller
                        -- If the variable is known, we produce a discount that
                        -- will take us back to 'max', the size of rh largest alternative
                        -- The 1+ is a little discount for reduced allocation in the caller

@@ -335,7 +334,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
     ------------
        -- We want to record if we're case'ing, or applying, an argument
 
     ------------
        -- We want to record if we're case'ing, or applying, an argument

-    fun_discount v | v `elem` top_args = SizeIs 0# (unitBag (v, opt_UF_FunAppDiscount)) 0#
+    fun_discount v | v `elem` top_args = SizeIs (_ILIT(0)) (unitBag (v, opt_UF_FunAppDiscount)) (_ILIT(0))

     fun_discount other                = sizeZero
 
     ------------
     fun_discount other                = sizeZero
 
     ------------

@@ -373,12 +372,12 @@ maxSize _              TooBig                               = TooBig
 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
                                              | otherwise = s2
 
 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
                                              | otherwise = s2
 

-sizeZero       = SizeIs (_ILIT 0)  emptyBag (_ILIT 0)
-sizeOne        = SizeIs (_ILIT 1)  emptyBag (_ILIT 0)
-sizeN n        = SizeIs (iUnbox n) emptyBag (_ILIT 0)
+sizeZero       = SizeIs (_ILIT(0))  emptyBag (_ILIT(0))
+sizeOne        = SizeIs (_ILIT(1))  emptyBag (_ILIT(0))
+sizeN n        = SizeIs (iUnbox n) emptyBag (_ILIT(0))

 conSizeN dc n   
 conSizeN dc n   

-  | isUnboxedTupleCon dc = SizeIs (_ILIT 0) emptyBag (iUnbox n +# _ILIT 1)
-  | otherwise           = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1)
+  | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n +# _ILIT(1))
+  | otherwise           = SizeIs (_ILIT(1)) emptyBag (iUnbox n +# _ILIT(1))

        -- Treat constructors as size 1; we are keen to expose them
        -- (and we charge separately for their args).  We can't treat
        -- them as size zero, else we find that (iBox x) has size 1,
        -- Treat constructors as size 1; we are keen to expose them
        -- (and we charge separately for their args).  We can't treat
        -- them as size zero, else we find that (iBox x) has size 1,

@@ -404,7 +403,7 @@ primOpSize op n_args
        -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
  | otherwise               = sizeOne
 
        -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
  | otherwise               = sizeOne
 

-buildSize = SizeIs (-2#) emptyBag 4#
+buildSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))

        -- We really want to inline applications of build
        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
        -- Indeed, we should add a result_discount becuause build is 
        -- We really want to inline applications of build
        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
        -- Indeed, we should add a result_discount becuause build is 

@@ -412,11 +411,11 @@ buildSize = SizeIs (-2#) emptyBag 4#
        -- build is saturated (it usually is).  The "-2" discounts for the \c n, 
        -- The "4" is rather arbitrary.
 
        -- build is saturated (it usually is).  The "-2" discounts for the \c n, 
        -- The "4" is rather arbitrary.
 

-augmentSize = SizeIs (-2#) emptyBag 4#
+augmentSize = SizeIs (_ILIT(-2)) emptyBag (_ILIT(4))

        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
        -- e plus ys. The -2 accounts for the \cn 
                                                
        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
        -- e plus ys. The -2 accounts for the \cn 
                                                

-nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
+nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs (_ILIT(0))

 nukeScrutDiscount TooBig         = TooBig
 
 -- When we return a lambda, give a discount if it's used (applied)
 nukeScrutDiscount TooBig         = TooBig
 
 -- When we return a lambda, give a discount if it's used (applied)

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 7162982..e97ab42 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -29,7 +29,7 @@ import FiniteMap
 
 import Data.Array
 import System.IO   (FilePath)
 
 import Data.Array
 import System.IO   (FilePath)

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

 import Compat.Directory ( createDirectoryIfMissing )
 #else
 import System.Directory ( createDirectoryIfMissing )
 import Compat.Directory ( createDirectoryIfMissing )
 #else
 import System.Directory ( createDirectoryIfMissing )

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 4fcf602..b9f0997 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -685,7 +685,7 @@ data ResType name
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-conDeclsNames :: forall name. Eq name => [ConDecl name] -> [Located name]
+conDeclsNames :: (Eq name) => [ConDecl name] -> [Located name]

   -- See tyClDeclNames for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
   -- See tyClDeclNames for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index c8ce17e..7683fae 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -370,12 +370,15 @@ ppr_expr (SectionR op expr)
     pp_infixly v
       = (sep [pprInfix v, pp_expr])
 
     pp_infixly v
       = (sep [pprInfix v, pp_expr])
 

-ppr_expr (HsLam matches :: HsExpr id)
-  = pprMatches (LambdaExpr :: HsMatchContext id) matches
+--avoid using PatternSignatures for stage1 code portability
+ppr_expr exprType@(HsLam matches)
+  = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
+ where idType :: HsExpr id -> HsMatchContext id; idType = undefined

 
 

-ppr_expr (HsCase expr matches :: HsExpr id)
+ppr_expr exprType@(HsCase expr matches)

   = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
   = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],

-          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ]
+          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches) ]
+ where idType :: HsExpr id -> HsMatchContext id; idType = undefined

 
 ppr_expr (HsIf e1 e2 e3)
   = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")],
 
 ppr_expr (HsIf e1 e2 e3)
   = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")],

@@ -699,8 +702,10 @@ pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
            => LPat bndr -> GRHSs id -> SDoc
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
            => LPat bndr -> GRHSs id -> SDoc

-pprPatBind pat (grhss :: GRHSs id)
- = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
+pprPatBind pat ty@(grhss)
+ = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
+--avoid using PatternSignatures for stage1 code portability
+ where idType :: GRHSs id -> HsMatchContext id; idType = undefined

 
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
 
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc

diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs
index 8d86582..60d1410 100644 (file)
--- a/compiler/main/BreakArray.hs
+++ b/compiler/main/BreakArray.hs
@@ -3,6 +3,10 @@
 -- Break Arrays in the IO monad
 -- Entries in the array are Word sized 
 --
 -- Break Arrays in the IO monad
 -- Entries in the array are Word sized 
 --

+-- Conceptually, a zero-indexed IOArray of Bools, initially False.
+-- They're represented as Words with 0==False, 1==True.
+-- They're used to determine whether GHCI breakpoints are on or off.
+--

 -- (c) The University of Glasgow 2007
 --
 -----------------------------------------------------------------------------
 -- (c) The University of Glasgow 2007
 --
 -----------------------------------------------------------------------------

@@ -15,15 +19,19 @@
 -- for details
 
 module BreakArray
 -- for details
 
 module BreakArray

-  ( BreakArray (BA)
-        -- constructor is exported only for ByteCodeGen
+  ( BreakArray
+#ifdef GHCI
+      (BA)  -- constructor is exported only for ByteCodeGen
+#endif

   , newBreakArray
   , newBreakArray

+#ifdef GHCI

   , getBreak 
   , setBreakOn 
   , setBreakOff
   , showBreakArray
   , getBreak 
   , setBreakOn 
   , setBreakOff
   , showBreakArray

+#endif

   ) where
   ) where

-
+#ifdef GHCI

 import GHC.Exts
 import GHC.IOBase
 import GHC.Word
 import GHC.Exts
 import GHC.IOBase
 import GHC.Word

@@ -105,3 +113,14 @@ readBA# array i = IO $ \s ->
 
 readBreakArray :: BreakArray -> Int -> IO Word 
 readBreakArray (BA array) (I# i) = readBA# array i
 
 readBreakArray :: BreakArray -> Int -> IO Word 
 readBreakArray (BA array) (I# i) = readBA# array i

+
+#else /* GHCI */
+--stub implementation to make main/, etc., code happier.
+--IOArray and IOUArray are increasingly non-portable,
+--still don't have quite the same interface, and (for GHCI)
+--presumably have a different representation.
+data BreakArray = Unspecified
+newBreakArray :: Int -> IO BreakArray
+newBreakArray _ = return Unspecified
+#endif /* GHCI */
+

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index e4559d4..d02582e 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -91,7 +91,7 @@ errMsgTc :: TyCon
 errMsgTc = mkTyCon "ErrMsg"
 {-# NOINLINE errMsgTc #-}
 instance Typeable ErrMsg where
 errMsgTc = mkTyCon "ErrMsg"
 {-# NOINLINE errMsgTc #-}
 instance Typeable ErrMsg where

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

   typeOf _ = mkAppTy errMsgTc []
 #else
   typeOf _ = mkTyConApp errMsgTc []
   typeOf _ = mkAppTy errMsgTc []
 #else
   typeOf _ = mkTyConApp errMsgTc []

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 7142645..5d6e41c 100644 (file)
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -46,13 +46,13 @@ import System.Exit
 import System.IO
 import Data.List
 
 import System.IO
 import Data.List
 

-#if __GLASGOW_HASKELL__ >= 601
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601

 import System.IO               ( openBinaryFile )
 #else
 import IOExts                   ( openFileEx, IOModeEx(..) )
 #endif
 
 import System.IO               ( openBinaryFile )
 #else
 import IOExts                   ( openFileEx, IOModeEx(..) )
 #endif
 

-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601

 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
 #endif
 
 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
 #endif
 

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 7f7fab8..7ad34ac 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1484,7 +1484,9 @@ data Unlinked
    | BCOs CompiledByteCode ModBreaks
 
 #ifndef GHCI
    | BCOs CompiledByteCode ModBreaks
 
 #ifndef GHCI

-data CompiledByteCode
+data CompiledByteCode = CompiledByteCodeUndefined
+_unused :: CompiledByteCode
+_unused = CompiledByteCodeUndefined

 #endif
 
 instance Outputable Unlinked where
 #endif
 
 instance Outputable Unlinked where

diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index d5cfbd1..749b91e 100644 (file)
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -54,7 +54,7 @@ import Maybes         ( expectJust, MaybeErr(..) )
 import Panic
 import Outputable
 
 import Panic
 import Outputable
 

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

 import Compat.Directory        ( getAppUserDataDirectory )
 #endif
 
 import Compat.Directory        ( getAppUserDataDirectory )
 #endif
 

diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs
index 41421d6..2df9a72 100644 (file)
--- a/compiler/main/SysTools.lhs
+++ b/compiler/main/SysTools.lhs
@@ -72,7 +72,7 @@ import Foreign
 import CString         ( CString, peekCString )
 #endif
 
 import CString         ( CString, peekCString )
 #endif
 

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

 -- rawSystem comes from libghccompat.a in stage1
 import Compat.RawSystem ( rawSystem )
 import System.Cmd       ( system )
 -- rawSystem comes from libghccompat.a in stage1
 import Compat.RawSystem ( rawSystem )
 import System.Cmd       ( system )

@@ -480,7 +480,7 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
 -- binaries (see bug #1110).
 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
 getGccEnv opts = 
 -- binaries (see bug #1110).
 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
 getGccEnv opts = 

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

   return Nothing
 #else
   if null b_dirs
   return Nothing
 #else
   if null b_dirs

@@ -747,7 +747,7 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
 
 
 
 
 
 

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

 builderMainLoop dflags filter_fn pgm real_args mb_env = do
   rawSystem pgm real_args
 #else
 builderMainLoop dflags filter_fn pgm real_args mb_env = do
   rawSystem pgm real_args
 #else

diff --git a/compiler/nativeGen/MachRegs.lhs b/compiler/nativeGen/MachRegs.lhs
index 522f715..85c88b2 100644 (file)
--- a/compiler/nativeGen/MachRegs.lhs
+++ b/compiler/nativeGen/MachRegs.lhs
@@ -103,11 +103,10 @@ import qualified Outputable
 import Unique
 import UniqSet
 import Constants
 import Unique
 import UniqSet
 import Constants

+import FastTypes

 import FastBool
 import UniqFM
 
 import FastBool
 import UniqFM
 

-import GHC.Exts
-

 #if powerpc_TARGET_ARCH
 import Data.Word       ( Word8, Word16, Word32 )
 import Data.Int        ( Int8, Int16, Int32 )
 #if powerpc_TARGET_ARCH
 import Data.Word       ( Word8, Word16, Word32 )
 import Data.Int        ( Int8, Int16, Int32 )

@@ -503,18 +502,18 @@ worst n classN classC
 -- Compare MachRegs.freeRegs  and MachRegs.h to get these numbers.
 --
 #if i386_TARGET_ARCH
 -- Compare MachRegs.freeRegs  and MachRegs.h to get these numbers.
 --
 #if i386_TARGET_ARCH

-#define ALLOCATABLE_REGS_INTEGER 3#
-#define ALLOCATABLE_REGS_DOUBLE  6#
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(3))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(6))

 #endif
 
 #if x86_64_TARGET_ARCH
 #endif
 
 #if x86_64_TARGET_ARCH

-#define ALLOCATABLE_REGS_INTEGER 5#
-#define ALLOCATABLE_REGS_DOUBLE  2#
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(5))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(2))

 #endif
 
 #if powerpc_TARGET_ARCH
 #endif
 
 #if powerpc_TARGET_ARCH

-#define ALLOCATABLE_REGS_INTEGER 16#
-#define ALLOCATABLE_REGS_DOUBLE  26#
+#define ALLOCATABLE_REGS_INTEGER (_ILIT(16))
+#define ALLOCATABLE_REGS_DOUBLE  (_ILIT(26))

 #endif
 
 {-# INLINE regClass      #-}
 #endif
 
 {-# INLINE regClass      #-}

@@ -535,17 +534,17 @@ trivColorable classN conflicts exclusions
                LeafUFM _ reg
                 -> case regClass reg of
                        RcInteger
                LeafUFM _ reg
                 -> case regClass reg of
                        RcInteger

-                        -> case cI +# 1# of
+                        -> case cI +# _ILIT(1) of

                                cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #)
 
                        RcDouble
                                cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #)
 
                        RcDouble

-                        -> case cF +# 1# of
+                        -> case cF +# _ILIT(1) of

                                cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE,  cI, cF' #)
 
                EmptyUFM
                 ->     (# False, cI, cF #)
 
                                cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE,  cI, cF' #)
 
                EmptyUFM
                 ->     (# False, cI, cF #)
 

-   in case isSqueesed 0# 0# conflicts of
+   in case isSqueesed (_ILIT(0)) (_ILIT(0)) conflicts of

        (# False, cI', cF' #)
         -> case isSqueesed cI' cF' exclusions of
                (# s, _, _ #)   -> not s
        (# False, cI', cF' #)
         -> case isSqueesed cI' cF' exclusions of
                (# s, _, _ #)   -> not s

diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs
index 60c35a3..51a0bff 100644 (file)
--- a/compiler/nativeGen/RegAllocColor.hs
+++ b/compiler/nativeGen/RegAllocColor.hs
@@ -60,7 +60,7 @@ regAlloc dflags regsFree slotsFree code
        return  ( code_final
                , reverse debug_codeGraphs )
 
        return  ( code_final
                , reverse debug_codeGraphs )
 

-regAlloc_spin dflags (spinCount :: Int) triv regsFree slotsFree debug_codeGraphs code
+regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code

  = do
        -- if any of these dump flags are turned on we want to hang on to
        --      intermediate structures in the allocator - otherwise tell the
  = do
        -- if any of these dump flags are turned on we want to hang on to
        --      intermediate structures in the allocator - otherwise tell the

diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs
index b6b2a73..d834a80 100644 (file)
--- a/compiler/nativeGen/RegAllocInfo.hs
+++ b/compiler/nativeGen/RegAllocInfo.hs
@@ -814,7 +814,7 @@ mkSpillInstr reg delta slot
                                     RcInteger -> I32;
                                    RcFloat   -> F32;
                                     RcDouble  -> F64}}
                                     RcInteger -> I32;
                                    RcFloat   -> F32;
                                     RcDouble  -> F64}}

-                        in ST sz reg (fpRel (- off_w))
+                        in ST sz reg (fpRel (negate off_w))

 #endif
 #ifdef powerpc_TARGET_ARCH
     let sz = case regClass reg of
 #endif
 #ifdef powerpc_TARGET_ARCH
     let sz = case regClass reg of

diff --git a/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y
index e3f45f9..d46223d 100644 (file)
--- a/compiler/parser/HaddockParse.y
+++ b/compiler/parser/HaddockParse.y
@@ -9,7 +9,7 @@
 module HaddockParse (
   parseHaddockParagraphs, 
   parseHaddockString, 
 module HaddockParse (
   parseHaddockParagraphs, 
   parseHaddockString, 

-  MyEither(..)
+  EitherString(..)

 ) where
 
 import {-# SOURCE #-} HaddockLex
 ) where
 
 import {-# SOURCE #-} HaddockLex

@@ -35,7 +35,7 @@ import RdrName
        PARA    { TokPara }
        STRING  { TokString $$ }
 
        PARA    { TokPara }
        STRING  { TokString $$ }
 

-%monad { MyEither String }
+%monad { EitherString }

 
 %name parseHaddockParagraphs  doc
 %name parseHaddockString seq
 
 %name parseHaddockParagraphs  doc
 %name parseHaddockString seq

@@ -98,15 +98,18 @@ strings  :: { String }
        | STRING strings        { $1 ++ $2 }
 
 {
        | STRING strings        { $1 ++ $2 }
 
 {

-happyError :: [Token] -> MyEither String a
+happyError :: [Token] -> EitherString a

 happyError toks = MyLeft ("parse error in doc string")
 
 -- We don't want to make an instance for Either String,
 -- since every user of the GHC API would get that instance
 
 happyError toks = MyLeft ("parse error in doc string")
 
 -- We don't want to make an instance for Either String,
 -- since every user of the GHC API would get that instance
 

-data MyEither a b = MyLeft a | MyRight b
+-- But why use non-Haskell98 instances when MyEither String
+-- is the only MyEither we're intending to use anyway? --Isaac Dupree
+--data MyEither a b = MyLeft a | MyRight b
+data EitherString b = MyLeft String | MyRight b

 
 

-instance Monad (MyEither String) where
+instance Monad EitherString where

        return          = MyRight
        MyLeft  l >>= _ = MyLeft l
        MyRight r >>= k = k r
        return          = MyRight
        MyLeft  l >>= _ = MyLeft l
        MyRight r >>= k = k r

diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index 57f5deb..b9014b2 100644 (file)
--- a/compiler/profiling/CostCentre.lhs
+++ b/compiler/profiling/CostCentre.lhs
@@ -292,8 +292,8 @@ cmpCostCentre other_1 other_2
     in
     if tag1 <# tag2 then LT else GT
   where
     in
     if tag1 <# tag2 then LT else GT
   where

-    tag_CC (NormalCC   {}) = (_ILIT 1 :: FastInt)
-    tag_CC (AllCafsCC  {}) = _ILIT 2
+    tag_CC (NormalCC   {}) = _ILIT(1)
+    tag_CC (AllCafsCC  {}) = _ILIT(2)

 
 cmp_caf NotCafCC CafCC     = LT
 cmp_caf NotCafCC NotCafCC  = EQ
 
 cmp_caf NotCafCC CafCC     = LT
 cmp_caf NotCafCC NotCafCC  = EQ

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 508bea6..66177a9 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -553,7 +553,9 @@ bindLocalFixities fixes thing_inside
         Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix)))
         Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix)))
 
         Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix)))
         Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix)))
 

-    nowAndLater (ls :: [Either (Name, FixItem) (FastString, Located Fixity)]) = 
+    nowAndLater :: [Either (Name, FixItem) (FastString, Located Fixity)]
+                       -> ([(Name,FixItem)], UniqFM (Located Fixity))
+    nowAndLater ls =

         foldr (\ cur -> \ (now, later) ->
                         case cur of 
                           Left (n, f) -> ((n, f) : now, later)
         foldr (\ cur -> \ (now, later) ->
                         case cur of 
                           Left (n, f) -> ((n, f) : now, later)

diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot
index b03f50a..5fba8c3 100644 (file)
--- a/compiler/rename/RnExpr.lhs-boot
+++ b/compiler/rename/RnExpr.lhs-boot
@@ -9,7 +9,7 @@ import TcRnTypes
 rnLExpr :: LHsExpr RdrName\r
        -> RnM (LHsExpr Name, FreeVars)\r
 \r
 rnLExpr :: LHsExpr RdrName\r
        -> RnM (LHsExpr Name, FreeVars)\r
 \r

-rnStmts :: forall thing.\r
+rnStmts :: --forall thing.\r

           HsStmtContext Name -> [LStmt RdrName] \r
        -> RnM (thing, FreeVars)\r
        -> RnM (([LStmt Name], thing), FreeVars)\r
           HsStmtContext Name -> [LStmt RdrName] \r
        -> RnM (thing, FreeVars)\r
        -> RnM (([LStmt Name], thing), FreeVars)\r

diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 3ab1c42..8c75caa 100644 (file)
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -384,7 +384,8 @@ rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont =
                 -- each list represents a RdrName that occurred more than once
                 -- (the list contains all occurrences)
                 -- invariant: each list in dup_fields is non-empty
                 -- each list represents a RdrName that occurred more than once
                 -- (the list contains all occurrences)
                 -- invariant: each list in dup_fields is non-empty

-                (_, dup_fields :: [[RdrName]]) = removeDups compare
+                dup_fields :: [[RdrName]]
+                (_, dup_fields) = removeDups compare

                                                  (map (unLoc . hsRecFieldId) fields)
                                              
                 -- duplicate field reporting function
                                                  (map (unLoc . hsRecFieldId) fields)
                                              
                 -- duplicate field reporting function

diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 7e9598c..1cdbde6 100644 (file)
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -50,8 +50,6 @@ import FastString     ( FastString )
 import Outputable
 import FastTypes
 
 import Outputable
 import FastTypes
 

-import GHC.Exts                ( indexArray# )
-

 import Data.Array
 import Data.Array.Base (unsafeAt)
 
 import Data.Array
 import Data.Array.Base (unsafeAt)
 

diff --git a/compiler/stranal/StrictAnal.lhs b/compiler/stranal/StrictAnal.lhs
index 0ae3269..5b19aea 100644 (file)
--- a/compiler/stranal/StrictAnal.lhs
+++ b/compiler/stranal/StrictAnal.lhs
@@ -409,7 +409,10 @@ data SaStats
            FastInt FastInt     -- total/marked-demanded let-bound
                                -- (excl. top-level; excl. letrecs)
 
            FastInt FastInt     -- total/marked-demanded let-bound
                                -- (excl. top-level; excl. letrecs)
 

-nullSaStats = SaStats (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0) (_ILIT 0)
+nullSaStats = SaStats
+   (_ILIT(0)) (_ILIT(0))
+   (_ILIT(0)) (_ILIT(0))
+   (_ILIT(0)) (_ILIT(0))

 
 thenSa       :: SaM a -> (a -> SaM b) -> SaM b
 thenSa_              :: SaM a -> SaM b -> SaM b
 
 thenSa       :: SaM a -> (a -> SaM b) -> SaM b
 thenSa_              :: SaM a -> SaM b -> SaM b

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index bd3cb8c..205197a 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -860,7 +860,7 @@ zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)

-zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs)
+zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)

   = mappM zonk_bndr vars               `thenM` \ new_bndrs ->
     newMutVar emptyVarSet              `thenM` \ unbound_tv_set ->
     let
   = mappM zonk_bndr vars               `thenM` \ new_bndrs ->
     newMutVar emptyVarSet              `thenM` \ unbound_tv_set ->
     let

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 897cca3..6003923 100644 (file)
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -45,10 +45,12 @@ module Binary
    lazyGet,
    lazyPut,
 
    lazyGet,
    lazyPut,
 

+#ifdef __GLASGOW_HASKELL__

    -- GHC only:
    ByteArray(..),
    getByteArray,
    putByteArray,
    -- GHC only:
    ByteArray(..),
    getByteArray,
    putByteArray,

+#endif

 
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
 
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,

@@ -84,7 +86,7 @@ import GHC.Real                       ( Ratio(..) )
 import GHC.Exts
 import GHC.IOBase              ( IO(..) )
 import GHC.Word                        ( Word8(..) )
 import GHC.Exts
 import GHC.IOBase              ( IO(..) )
 import GHC.Word                        ( Word8(..) )

-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601

 -- openFileEx is available from the lang package, but we want to 
 -- be independent of hslibs libraries.
 import GHC.Handle              ( openFileEx, IOModeEx(..) )
 -- openFileEx is available from the lang package, but we want to 
 -- be independent of hslibs libraries.
 import GHC.Handle              ( openFileEx, IOModeEx(..) )

@@ -92,7 +94,7 @@ import GHC.Handle             ( openFileEx, IOModeEx(..) )
 import System.IO               ( openBinaryFile )
 #endif
 
 import System.IO               ( openBinaryFile )
 #endif
 

-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601

 openBinaryFile f mode = openFileEx f (BinaryMode mode)
 #endif
 
 openBinaryFile f mode = openFileEx f (BinaryMode mode)
 #endif
 

@@ -457,7 +459,21 @@ instance (Binary a, Binary b) => Binary (Either a b) where
                              0 -> do a <- get bh ; return (Left a)
                              _ -> do b <- get bh ; return (Right b)
 
                              0 -> do a <- get bh ; return (Left a)
                              _ -> do b <- get bh ; return (Right b)
 

-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || 1
+--to quote binary-0.3 on this code idea,
+--
+-- TODO  This instance is not architecture portable.  GMP stores numbers as
+-- arrays of machine sized words, so the byte format is not portable across
+-- architectures with different endianess and word size.
+--
+-- This makes it hard (impossible) to make an equivalent instance
+-- with code that is compilable with non-GHC.  Do we need any instance
+-- Binary Integer, and if so, does it have to be blazing fast?  Or can
+-- we just change this instance to be portable like the rest of the
+-- instances? (binary package has code to steal for that)
+--
+-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.lhs
+

 instance Binary Integer where
     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
     put_ bh (J# s# a#) = do
 instance Binary Integer where
     put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
     put_ bh (J# s# a#) = do

@@ -477,6 +493,10 @@ instance Binary Integer where
                  (BA a#) <- getByteArray bh sz
                  return (J# s# a#)
 
                  (BA a#) <- getByteArray bh sz
                  return (J# s# a#)
 

+-- As for the rest of this code, even though this module
+-- exports it, it doesn't seem to be used anywhere else
+-- in GHC!
+

 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 putByteArray bh a s# = loop 0#
   where loop n# 
 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
 putByteArray bh a s# = loop 0#
   where loop n# 

diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs
index d625a6e..3064135 100644 (file)
--- a/compiler/utils/BufWrite.hs
+++ b/compiler/utils/BufWrite.hs
@@ -23,6 +23,7 @@ module BufWrite (
 #include "HsVersions.h"
 
 import FastString
 #include "HsVersions.h"
 
 import FastString

+import FastTypes

 import FastMutInt
 
 import Control.Monad   ( when )
 import FastMutInt
 
 import Control.Monad   ( when )

@@ -30,11 +31,6 @@ import Data.Char     ( ord )
 import Foreign
 import System.IO
 
 import Foreign
 import System.IO
 

-import GHC.IOBase      ( IO(..) )
-import GHC.Ptr         ( Ptr(..) )
-
-import GHC.Exts                ( Int(..), Int#, Addr# )
-

 -- -----------------------------------------------------------------------------
 
 data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)
 -- -----------------------------------------------------------------------------
 
 data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8)

@@ -94,18 +90,18 @@ bPutFS b@(BufHandle buf r hdl) fs@(FastString _ len _ fp _) =
                copyBytes (buf `plusPtr` i) ptr len
                writeFastMutInt r (i+len)
 
                copyBytes (buf `plusPtr` i) ptr len
                writeFastMutInt r (i+len)
 

-bPutLitString :: BufHandle -> Addr# -> Int# -> IO ()
-bPutLitString b@(BufHandle buf r hdl) a# len# = do
-  let len = I# len#
+bPutLitString :: BufHandle -> LitString -> FastInt -> IO ()
+bPutLitString b@(BufHandle buf r hdl) a len_ = a `seq` do
+  let len = iBox len_

   i <- readFastMutInt r
   if (i+len) >= buf_size
        then do hPutBuf hdl buf i
                writeFastMutInt r 0
                if (len >= buf_size) 
   i <- readFastMutInt r
   if (i+len) >= buf_size
        then do hPutBuf hdl buf i
                writeFastMutInt r 0
                if (len >= buf_size) 

-                   then hPutBuf hdl (Ptr a#) len
-                   else bPutLitString b a# len#
+                   then hPutBuf hdl a len
+                   else bPutLitString b a len_

        else do
        else do

-               copyBytes (buf `plusPtr` i) (Ptr a#) len
+               copyBytes (buf `plusPtr` i) a len

                writeFastMutInt r (i+len)
 
 bFlush :: BufHandle -> IO ()
                writeFastMutInt r (i+len)
 
 bFlush :: BufHandle -> IO ()

diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs
index f80b33f..939dc49 100644 (file)
--- a/compiler/utils/Digraph.lhs
+++ b/compiler/utils/Digraph.lhs
@@ -54,7 +54,7 @@ import Data.Maybe
 import Data.Array
 import Data.List
 
 import Data.Array
 import Data.List
 

-#if __GLASGOW_HASKELL__ > 604
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604

 import Data.Array.ST
 #else
 import Data.Array.ST  hiding ( indices, bounds )
 import Data.Array.ST
 #else
 import Data.Array.ST  hiding ( indices, bounds )

diff --git a/compiler/utils/FastBool.lhs b/compiler/utils/FastBool.lhs
index d7776e4..ee9b40f 100644 (file)
--- a/compiler/utils/FastBool.lhs
+++ b/compiler/utils/FastBool.lhs
@@ -5,6 +5,7 @@
 
 \begin{code}
 module FastBool (
 
 \begin{code}
 module FastBool (

+    --fastBool could be called bBox; isFastTrue, bUnbox; but they're not

     FastBool, fastBool, isFastTrue, fastOr, fastAnd
   ) where
 
     FastBool, fastBool, isFastTrue, fastOr, fastAnd
   ) where
 

@@ -12,25 +13,55 @@ module FastBool (
 
 -- Import the beggars
 import GHC.Exts
 
 -- Import the beggars
 import GHC.Exts

-       ( Int(..), Int#, (+#), (-#), (*#), 
-         quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#)
-       )

 import Panic
 
 type FastBool = Int#
 fastBool True  = 1#
 fastBool False = 0#
 import Panic
 
 type FastBool = Int#
 fastBool True  = 1#
 fastBool False = 0#

-isFastTrue x = x ==# 1#
+
+#ifdef DEBUG
+--then waste time deciding whether to panic. FastBool should normally
+--be at least as fast as Bool, one would hope...
+
+isFastTrue 1# = True
+isFastTrue 0# = False
+isFastTrue _ = panic "FastTypes: isFastTrue"

 
 -- note that fastOr and fastAnd are strict in both arguments
 -- since they are unboxed
 fastOr 1# _ = 1#
 fastOr 0# x = x
 
 -- note that fastOr and fastAnd are strict in both arguments
 -- since they are unboxed
 fastOr 1# _ = 1#
 fastOr 0# x = x

-fastOr _  _ = panic# "FastTypes: fastOr"
+fastOr _  _ = panicFastInt "FastTypes: fastOr"

 
 fastAnd 0# _ = 0#
 fastAnd 1# x = x
 
 fastAnd 0# _ = 0#
 fastAnd 1# x = x

-fastAnd _  _ = panic# "FastTypes: fastAnd"
+fastAnd _  _ = panicFastInt "FastTypes: fastAnd"
+
+--these "panicFastInt"s (formerly known as "panic#") rely on
+--FastInt = FastBool ( = Int# presumably),
+--haha, true enough when __GLASGOW_HASKELL__.  Why can't we have functions
+--that return _|_ be kind-polymorphic ( ?? to be precise ) ?
+
+#else /* ! DEBUG */
+--Isn't comparison to zero sometimes faster on CPUs than comparison to 1?
+-- (since using Int# as _synonym_ fails to guarantee that it will
+--   only take on values of 0 and 1)
+isFastTrue 0# = False
+isFastTrue _ = True
+
+-- note that fastOr and fastAnd are strict in both arguments
+-- since they are unboxed
+-- Also, to avoid incomplete-pattern warning
+-- (and avoid wasting time with redundant runtime checks),
+-- we don't pattern-match on both 0# and 1# .
+fastOr 0# x = x
+fastOr _  _ = 1#
+
+fastAnd 0# _ = 0#
+fastAnd _  x = x
+
+#endif /* ! DEBUG */
+

 
 #else /* ! __GLASGOW_HASKELL__ */
 
 
 #else /* ! __GLASGOW_HASKELL__ */
 

diff --git a/compiler/utils/FastFunctions.lhs b/compiler/utils/FastFunctions.lhs
new file mode 100644 (file)
index 0000000..5d8ff23
--- /dev/null
+++ b/compiler/utils/FastFunctions.lhs
@@ -0,0 +1,80 @@
+Z%
+% (c) The University of Glasgow, 2000-2006
+%
+\section{Fast functions}
+
+\begin{code}
+
+module FastFunctions (
+    unsafeChr, inlinePerformIO, unsafeDupableInterleaveIO,
+    indexWord8OffFastPtr,
+    indexWord8OffFastPtrAsFastChar, indexWord8OffFastPtrAsFastInt,
+    global, Global
+  ) where
+
+#define COMPILING_FAST_STRING
+#include "HsVersions.h"
+
+import FastTypes
+import Data.IORef
+import System.IO.Unsafe
+
+#if defined(__GLASGOW_HASKELL__)
+
+import GHC.Exts
+import GHC.Word
+import GHC.IOBase (IO(..))
+--why not import it at __GLASGOW_HASKELL__==606 ?
+#if __GLASGOW_HASKELL__ >= 607
+import GHC.IOBase (unsafeDupableInterleaveIO)
+#endif
+import GHC.Base (unsafeChr)
+
+#if __GLASGOW_HASKELL__ < 607
+unsafeDupableInterleaveIO :: IO a -> IO a
+unsafeDupableInterleaveIO = unsafeInterleaveIO
+#endif
+
+-- Just like unsafePerformIO, but we inline it.
+{-# INLINE inlinePerformIO #-}
+inlinePerformIO :: IO a -> a
+inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
+
+indexWord8OffFastPtr p i = W8# (indexWord8OffAddr# p i)
+indexWord8OffFastPtrAsFastChar p i = indexCharOffAddr# p i
+indexWord8OffFastPtrAsFastInt p i = word2Int# (indexWord8OffAddr# p i)
+-- or ord# (indexCharOffAddr# p i)
+
+#else /* ! __GLASGOW_HASKELL__ */
+
+import Foreign.Ptr
+import Data.Word
+
+-- hey, no harm inlining it, :-P
+{-# INLINE inlinePerformIO #-}
+inlinePerformIO :: IO a -> a
+inlinePerformIO = unsafePerformIO
+
+unsafeDupableInterleaveIO :: IO a -> IO a
+unsafeDupableInterleaveIO = unsafeInterleaveIO
+
+-- truly, these functions are unsafe: they assume
+-- a certain immutability of the pointer's target area.
+indexWord8OffFastPtr p i = inlinePerformIO (peekByteOff p n) :: Word8
+indexWord8OffFastPtrAsFastInt p i =
+  iUnbox (fromIntegral (inlinePerformIO (peekByteOff p n) :: Word8))
+indexWord8OffFastPtrAsFastChar p i =
+  fastChr (iUnbox (fromIntegral (inlinePerformIO (peekByteOff p n) :: Word8)))
+
+#endif /* ! __GLASGOW_HASKELL__ */
+
+--just so we can refer to the type clearly in a macro
+type Global a = IORef a
+global :: a -> Global a
+global a = unsafePerformIO (newIORef a)
+
+indexWord8OffFastPtr :: FastPtr Word8 -> FastInt -> Word8
+indexWord8OffFastPtrAsFastChar :: FastPtr Word8 -> FastInt -> FastChar
+indexWord8OffFastPtrAsFastInt :: FastPtr Word8 -> FastInt -> FastInt
+
+\end{code}

diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs
index ca7c2c7..a22cae0 100644 (file)
--- a/compiler/utils/FastString.lhs
+++ b/compiler/utils/FastString.lhs
@@ -33,7 +33,9 @@ module FastString
        mkFastStringBytes,
         mkFastStringByteList,
        mkFastStringForeignPtr,
        mkFastStringBytes,
         mkFastStringByteList,
        mkFastStringForeignPtr,

+#if defined(__GLASGOW_HASKELL__)

        mkFastString#,
        mkFastString#,

+#endif

        mkZFastString,
        mkZFastStringBytes,
 
        mkZFastString,
        mkZFastStringBytes,
 

@@ -65,8 +67,15 @@ module FastString
 
        -- * LitStrings
        LitString, 
 
        -- * LitStrings
        LitString, 

+#if defined(__GLASGOW_HASKELL__)

        mkLitString#,
        mkLitString#,

-       strLength
+#else
+       mkLitString,
+#endif
+       unpackLitString,
+       strLength,
+
+       ptrStrLength

        ) where
 
 -- This #define suppresses the "import FastString" that
        ) where
 
 -- This #define suppresses the "import FastString" that

@@ -75,6 +84,8 @@ module FastString
 #include "HsVersions.h"
 
 import Encoding
 #include "HsVersions.h"
 
 import Encoding

+import FastTypes
+import FastFunctions

 
 import Foreign
 import Foreign.C
 
 import Foreign
 import Foreign.C

@@ -84,6 +95,7 @@ import Control.Monad.ST       ( stToIO )
 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 import System.IO       ( hPutBuf )
 import Data.Maybe      ( isJust )
 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 import System.IO       ( hPutBuf )
 import Data.Maybe      ( isJust )

+import Data.Char       ( ord )

 
 import GHC.ST
 import GHC.IOBase      ( IO(..) )
 
 import GHC.ST
 import GHC.IOBase      ( IO(..) )

@@ -188,7 +200,7 @@ updTbl fs_table_var (FastStringTable uid arr#) (I# i#) ls = do
   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 
 mkFastString# :: Addr# -> FastString
   writeIORef fs_table_var (FastStringTable (uid+1) arr#)
 
 mkFastString# :: Addr# -> FastString

-mkFastString# a# = mkFastStringBytes ptr (strLength ptr)
+mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)

   where ptr = Ptr a#
 
 mkFastStringBytes :: Ptr Word8 -> Int -> FastString
   where ptr = Ptr a#
 
 mkFastStringBytes :: Ptr Word8 -> Int -> FastString

@@ -352,10 +364,10 @@ hashStr  :: Ptr Word8 -> Int -> Int
  -- use the Addr to produce a hash value between 0 & m (inclusive)
 hashStr (Ptr a#) (I# len#) = loop 0# 0#
    where 
  -- use the Addr to produce a hash value between 0 & m (inclusive)
 hashStr (Ptr a#) (I# len#) = loop 0# 0#
    where 

-    loop h n | n ==# len# = I# h
-            | otherwise  = loop h2 (n +# 1#)
+    loop h n | n GHC.Exts.==# len# = I# h
+            | otherwise  = loop h2 (n GHC.Exts.+# 1#)

          where c = ord# (indexCharOffAddr# a# n)
          where c = ord# (indexCharOffAddr# a# n)

-               h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE#
+               h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` hASH_TBL_SIZE#

 
 -- -----------------------------------------------------------------------------
 -- Operations
 
 -- -----------------------------------------------------------------------------
 -- Operations

@@ -446,8 +458,8 @@ tailFS (FastString _ n_bytes _ buf enc) =
 consFS :: Char -> FastString -> FastString
 consFS c fs = mkFastString (c : unpackFS fs)
 
 consFS :: Char -> FastString -> FastString
 consFS c fs = mkFastString (c : unpackFS fs)
 

-uniqueOfFS :: FastString -> Int#
-uniqueOfFS (FastString (I# u#) _ _ _ _) = u#
+uniqueOfFS :: FastString -> FastInt
+uniqueOfFS (FastString u _ _ _ _) = iUnbox u

 
 nilFS = mkFastString ""
 
 
 nilFS = mkFastString ""
 

@@ -475,23 +487,77 @@ hPutFS handle (FastString _ len _ fp _)
 -- -----------------------------------------------------------------------------
 -- LitStrings, here for convenience only.
 
 -- -----------------------------------------------------------------------------
 -- LitStrings, here for convenience only.
 

-type LitString = Ptr ()
+-- hmm, not unboxed (or rather FastPtr), interesting
+--a.k.a. Ptr CChar, Ptr Word8, Ptr (), hmph.  We don't
+--really care about C types in naming, where we can help it.
+type LitString = Ptr Word8
+--Why do we recalculate length every time it's requested?
+--If it's commonly needed, we should perhaps have
+--data LitString = LitString {-#UNPACK#-}!(FastPtr Word8) {-#UNPACK#-}!FastInt

 
 

+#if defined(__GLASGOW_HASKELL__)

 mkLitString# :: Addr# -> LitString
 mkLitString# a# = Ptr a#
 mkLitString# :: Addr# -> LitString
 mkLitString# a# = Ptr a#

+#endif

 
 

-foreign import ccall unsafe "ghc_strlen" 
-  strLength :: Ptr () -> Int
+--can/should we use FastTypes here?
+--Is this likely to be memory-preserving if only used on constant strings?
+--should we inline it? If lucky, that would make a CAF that wouldn't
+--be computationally repeated... although admittedly we're not
+--really intending to use mkLitString when __GLASGOW_HASKELL__...
+--(I wonder, is unicode / multi-byte characters allowed in LitStrings
+-- at all?)
+{-# INLINE mkLitString #-}
+mkLitString :: String -> LitString
+mkLitString s =
+ unsafePerformIO (do
+   p <- mallocBytes (length s + 1)
+   let
+     loop :: Int -> String -> IO ()
+     loop n cs | n `seq` null cs = pokeByteOff p n (0 :: Word8)
+     loop n (c:cs) = do
+        pokeByteOff p n (fromIntegral (ord c) :: Word8)
+        loop (1+n) cs
+   loop 0 s
+   return p
+ )
+
+unpackLitString :: LitString -> String
+unpackLitString p_ = case pUnbox p_ of
+ p -> unpack (_ILIT(0))
+  where
+    unpack n = case indexWord8OffFastPtrAsFastChar p n of
+      ch -> if ch `eqFastChar` _CLIT('\0')
+            then [] else cBox ch : unpack (n +# _ILIT(1))
+
+strLength :: LitString -> Int
+strLength = ptrStrLength
+
+-- for now, use a simple String representation
+--no, let's not do that right now - it's work in other places
+#if 0
+type LitString = String
+
+mkLitString :: String -> LitString
+mkLitString = id
+
+unpackLitString :: LitString -> String
+unpackLitString = id
+
+strLength :: LitString -> Int
+strLength = length
+
+#endif

 
 -- -----------------------------------------------------------------------------
 -- under the carpet
 
 
 -- -----------------------------------------------------------------------------
 -- under the carpet
 

--- Just like unsafePerformIO, but we inline it.
-{-# INLINE inlinePerformIO #-}
-inlinePerformIO :: IO a -> a
-inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
+foreign import ccall unsafe "ghc_strlen" 
+  ptrStrLength :: Ptr Word8 -> Int

 
 -- NB. does *not* add a '\0'-terminator.
 
 -- NB. does *not* add a '\0'-terminator.

+-- We only use CChar here to be parallel to the imported
+-- peekC(A)StringLen.

 pokeCAString :: Ptr CChar -> String -> IO ()
 pokeCAString ptr str =
   let
 pokeCAString :: Ptr CChar -> String -> IO ()
 pokeCAString ptr str =
   let

@@ -500,7 +566,7 @@ pokeCAString ptr str =
   in
   go str 0
 
   in
   go str 0
 

-#if __GLASGOW_HASKELL__ <= 602
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 602

 peekCAStringLen = peekCStringLen
 #endif
 \end{code}
 peekCAStringLen = peekCStringLen
 #endif
 \end{code}

diff --git a/compiler/utils/FastTypes.lhs b/compiler/utils/FastTypes.lhs
index bce98f4..71a317b 100644 (file)
--- a/compiler/utils/FastTypes.lhs
+++ b/compiler/utils/FastTypes.lhs
@@ -1,32 +1,106 @@
 %
 % (c) The University of Glasgow, 2000-2006
 %
 %
 % (c) The University of Glasgow, 2000-2006
 %

-\section{Fast integers and booleans}
+\section{Fast integers, etc... booleans moved to FastBool for using panic}

 
 \begin{code}
 
 \begin{code}

+
+--Even if the optimizer could handle boxed arithmetic equally well,
+--this helps automatically check the sources to make sure that
+--it's only used in an appropriate pattern of efficiency.
+--(it also makes `let`s and `case`s stricter...)
+

 module FastTypes (
     FastInt, _ILIT, iBox, iUnbox,
     (+#), (-#), (*#), quotFastInt, negateFastInt,
 module FastTypes (
     FastInt, _ILIT, iBox, iUnbox,
     (+#), (-#), (*#), quotFastInt, negateFastInt,

-    (==#), (<#), (<=#), (>=#), (>#),
+    --quotRemFastInt is difficult because unboxed values can't
+    --be tupled, but unboxed tuples aren't portable.  Just use
+    -- nuisance boxed quotRem and rely on optimization.
+    (==#), (/=#), (<#), (<=#), (>=#), (>#),
+    minFastInt, maxFastInt,
+    --prefer to distinguish operations, not types, between
+    --signed and unsigned.
+    --left-shift is the same for 'signed' and 'unsigned' numbers
+    shiftLFastInt,
+    --right-shift isn't the same for negative numbers (ones with
+    --the highest-order bit '1').  If you don't care because the
+    --number you're shifting is always nonnegative, use the '_' version
+    --which should just be the fastest one.
+    shiftR_FastInt,
+    --"L' = logical or unsigned shift; 'A' = arithmetic or signed shift
+    shiftRLFastInt, shiftRAFastInt,
+    bitAndFastInt, bitOrFastInt,
+    --add more operations to this file as you need them
+
+    --note, fastChr is "unsafe"Chr: it doesn't check for
+    --character values above the range of Unicode
+    FastChar, _CLIT, cBox, cUnbox, fastOrd, fastChr, eqFastChar,
+
+    FastPtr, pBox, pUnbox, castFastPtr

   ) where
 
   ) where
 

+#define COMPILING_FAST_STRING
+#include "HsVersions.h"
+

 #if defined(__GLASGOW_HASKELL__)
 
 -- Import the beggars
 import GHC.Exts
 #if defined(__GLASGOW_HASKELL__)
 
 -- Import the beggars
 import GHC.Exts

-       ( Int(..), Int#, (+#), (-#), (*#), 
-         quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#)
-       )

 
 type FastInt = Int#
 
 type FastInt = Int#

-_ILIT (I# x) = x
+
+--in case it's a macro, don't lexically feed an argument!
+--e.g. #define _ILIT(x) (x#) , #define _ILIT(x) (x :: FastInt)
+_ILIT = \(I# x) -> x
+--perhaps for accomodating caseless-leading-underscore treatment,
+--something like _iLIT or iLIT would be better?
+

 iBox x = I# x
 iUnbox (I# x) = x
 quotFastInt   = quotInt#
 negateFastInt = negateInt#
 
 iBox x = I# x
 iUnbox (I# x) = x
 quotFastInt   = quotInt#
 negateFastInt = negateInt#
 

+--I think uncheckedIShiftL# and uncheckedIShiftRL# are the same
+--as uncheckedShiftL# and uncheckedShiftRL# ...
+--should they be used? How new are they?
+--They existed as far back as GHC 6.0 at least...
+shiftLFastInt x y = uncheckedIShiftL# x y
+shiftR_FastInt x y = uncheckedIShiftRL# x y
+shiftRLFastInt x y = uncheckedIShiftRL# x y
+shiftRAFastInt x y = uncheckedIShiftRA# x y
+--{-# INLINE shiftLNonnegativeFastInt #-}
+--{-# INLINE shiftRNonnegativeFastInt #-}
+--shiftLNonnegativeFastInt n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
+--shiftRNonnegativeFastInt n p = word2Int#((int2Word# n) `uncheckedShiftRL#` p)
+bitAndFastInt x y = word2Int# (and# (int2Word# x) (int2Word# y))
+bitOrFastInt x y = word2Int# (or# (int2Word# x) (int2Word# y))
+
+type FastChar = Char#
+_CLIT = \(C# c) -> c
+cBox c = C# c
+cUnbox (C# c) = c
+fastOrd c = ord# c
+fastChr x = chr# x
+eqFastChar a b = eqChar# a b
+
+--note that the type-parameter doesn't provide any safety
+--when it's a synonym, but as long as we keep it compiling
+--with and without __GLASGOW_HASKELL__ defined, it's fine.
+type FastPtr a = Addr#
+pBox p = Ptr p
+pUnbox (Ptr p) = p
+castFastPtr p = p
+

 #else /* ! __GLASGOW_HASKELL__ */
 
 #else /* ! __GLASGOW_HASKELL__ */
 

+import Data.Char (ord, chr)
+
+import Data.Bits
+import Data.Word (Word) --is it a good idea to assume this exists too?
+--does anyone need shiftRLFastInt? (apparently yes.)
+
+import Foreign.Ptr
+

 type FastInt = Int
 _ILIT x = x
 iBox x = x
 type FastInt = Int
 _ILIT x = x
 iBox x = x

@@ -35,27 +109,64 @@ iUnbox x = x
 (-#) = (-)
 (*#) = (*)
 quotFastInt   = quot
 (-#) = (-)
 (*#) = (*)
 quotFastInt   = quot

+--quotRemFastInt = quotRem

 negateFastInt = negate
 (==#) = (==)
 negateFastInt = negate
 (==#) = (==)

+(/=#) = (/=)

 (<#)  = (<)
 (<=#) = (<=)
 (>=#) = (>=)
 (>#)  = (>)
 (<#)  = (<)
 (<=#) = (<=)
 (>=#) = (>=)
 (>#)  = (>)

+shiftLFastInt = shiftL
+shiftR_FastInt = shiftR
+shiftRAFastInt = shiftR
+shiftRLFastInt n p = fromIntegral (shiftR (fromIntegral n :: Word) p)
+--shiftLFastInt n p = n * (2 ^ p)
+--assuming quot-Int is faster and the
+--same for nonnegative arguments than div-Int
+--shiftR_FastInt n p = n `quot` (2 ^ p)
+--shiftRAFastInt n p = n `div` (2 ^ p)
+--I couldn't figure out how to implement without Word nor Bits
+--shiftRLFastInt n p = fromIntegral ((fromIntegral n :: Word) `quot` (2 ^ (fromIntegral p :: Word)))
+
+bitAndFastInt = (.&.)
+bitOrFastInt = (.|.)
+
+type FastBool = Bool
+fastBool x = x
+isFastTrue x = x
+-- make sure these are as strict as the unboxed version,
+-- so that the performance characteristics match
+fastOr False False = False
+fastOr _ _ = True
+fastAnd True True = True
+fastAnd _ _ = False
+
+type FastChar = Char
+_CLIT c = c
+cBox c = c
+cUnbox c = c
+fastOrd = ord
+fastChr = chr  --or unsafeChr if there was a standard location for it
+eqFastChar = (==)
+
+type FastPtr a = Ptr a
+pBox p = p
+pUnbox p = p
+castFastPtr = castPtr

 
 --These are among the type-signatures necessary for !ghc to compile
 -- but break ghc (can't give a signature for an import...)
 --Note that the comparisons actually do return Bools not FastBools.
 
 --These are among the type-signatures necessary for !ghc to compile
 -- but break ghc (can't give a signature for an import...)
 --Note that the comparisons actually do return Bools not FastBools.

-(+#) :: FastInt -> FastInt -> FastInt
-(-#) :: FastInt -> FastInt -> FastInt
-(*#) :: FastInt -> FastInt -> FastInt
-(==#) :: FastInt -> FastInt -> Bool
-(<#) :: FastInt -> FastInt -> Bool
-(<=#) :: FastInt -> FastInt -> Bool
-(>=#) :: FastInt -> FastInt -> Bool
-(>#) :: FastInt -> FastInt -> Bool
+(+#), (-#), (*#) :: FastInt -> FastInt -> FastInt
+(==#), (/=#), (<#), (<=#), (>=#), (>#) :: FastInt -> FastInt -> Bool

 
 #endif /* ! __GLASGOW_HASKELL__ */
 
 
 #endif /* ! __GLASGOW_HASKELL__ */
 

+minFastInt, maxFastInt :: FastInt -> FastInt -> FastInt
+minFastInt x y = if x <# y then x else y
+maxFastInt x y = if x <# y then y else x
+

 -- type-signatures will improve the non-ghc-specific versions
 -- and keep things accurate (and ABLE to compile!)
 _ILIT :: Int -> FastInt
 -- type-signatures will improve the non-ghc-specific versions
 -- and keep things accurate (and ABLE to compile!)
 _ILIT :: Int -> FastInt

@@ -64,5 +175,19 @@ iUnbox :: Int -> FastInt
 
 quotFastInt :: FastInt -> FastInt -> FastInt
 negateFastInt :: FastInt -> FastInt
 
 quotFastInt :: FastInt -> FastInt -> FastInt
 negateFastInt :: FastInt -> FastInt

+shiftLFastInt, shiftR_FastInt, shiftRAFastInt, shiftRLFastInt
+   :: FastInt -> FastInt -> FastInt
+bitAndFastInt, bitOrFastInt :: FastInt -> FastInt -> FastInt
+
+_CLIT :: Char -> FastChar
+cBox :: FastChar -> Char
+cUnbox :: Char -> FastChar
+fastOrd :: FastChar -> FastInt
+fastChr :: FastInt -> FastChar
+eqFastChar :: FastChar -> FastChar -> Bool
+
+pBox :: FastPtr a -> Ptr a
+pUnbox :: Ptr a -> FastPtr a
+castFastPtr :: FastPtr a -> FastPtr b

 
 \end{code}
 
 \end{code}

diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs
index d3a2c64..b3dfb27 100644 (file)
--- a/compiler/utils/FiniteMap.lhs
+++ b/compiler/utils/FiniteMap.lhs
@@ -679,7 +679,7 @@ When the FiniteMap module is used in GHC, we specialise it for
 \begin{code}
 #if 0
 
 \begin{code}
 #if 0
 

-#if __GLASGOW_HASKELL__
+#ifdef __GLASGOW_HASKELL__

 
 {-# SPECIALIZE addListToFM
                :: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
 
 {-# SPECIALIZE addListToFM
                :: FiniteMap (FastString, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 839eda1..ef856d0 100644 (file)
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -45,9 +45,9 @@ module Outputable (
        pprHsChar, pprHsString,
 
        -- error handling
        pprHsChar, pprHsString,
 
        -- error handling

-       pprPanic, assertPprPanic, pprPanic#, pprPgmError, 
+       pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, 

        pprTrace, warnPprTrace,
        pprTrace, warnPprTrace,

-       trace, pgmError, panic, panic#, assertPanic
+       trace, pgmError, panic, panicFastInt, assertPanic

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -59,7 +59,6 @@ import {-# SOURCE #-}         OccName( OccName )
 import StaticFlags     ( opt_PprStyle_Debug, opt_PprUserLength )
 import FastString
 import FastTypes
 import StaticFlags     ( opt_PprStyle_Debug, opt_PprUserLength )
 import FastString
 import FastTypes

-import GHC.Ptr

 import qualified Pretty
 import Pretty          ( Doc, Mode(..) )
 import Panic
 import qualified Pretty
 import Pretty          ( Doc, Mode(..) )
 import Panic

@@ -336,7 +335,7 @@ empty    :: SDoc
 text     :: String     -> SDoc
 char     :: Char       -> SDoc
 ftext    :: FastString -> SDoc
 text     :: String     -> SDoc
 char     :: Char       -> SDoc
 ftext    :: FastString -> SDoc

-ptext    :: Ptr t      -> SDoc
+ptext    :: LitString  -> SDoc

 int      :: Int        -> SDoc
 integer  :: Integer    -> SDoc
 float    :: Float      -> SDoc
 int      :: Int        -> SDoc
 integer  :: Integer    -> SDoc
 float    :: Float      -> SDoc

@@ -625,8 +624,8 @@ pprPgmError = pprAndThen pgmError   -- Throw an exn saying "bug in pgm being compi
                                        --      (used for unusual pgm errors)
 pprTrace    = pprAndThen trace
 
                                        --      (used for unusual pgm errors)
 pprTrace    = pprAndThen trace
 

-pprPanic# :: String -> SDoc -> FastInt
-pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
+pprPanicFastInt :: String -> SDoc -> FastInt
+pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))

                             where
                               doc = text heading <+> pretty_msg
 
                             where
                               doc = text heading <+> pretty_msg
 

diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 94f01d4..defbbef 100644 (file)
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -14,7 +14,7 @@ module Panic
      GhcException(..), showGhcException, ghcError, progName, 
      pgmError,
 
      GhcException(..), showGhcException, ghcError, progName, 
      pgmError,
 

-     panic, panic#, assertPanic, trace,
+     panic, panicFastInt, assertPanic, trace,

      
      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
      catchJust, ioErrors, throwTo,
      
      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
      catchJust, ioErrors, throwTo,

@@ -118,7 +118,7 @@ showGhcException (Panic s)
                 ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 
 myMkTyConApp :: TyCon -> [TypeRep] -> TypeRep
                 ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 
 myMkTyConApp :: TyCon -> [TypeRep] -> TypeRep

-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603

 myMkTyConApp = mkAppTy
 #else 
 myMkTyConApp = mkTyConApp
 myMkTyConApp = mkAppTy
 #else 
 myMkTyConApp = mkTyConApp

@@ -142,8 +142,8 @@ pgmError x = Exception.throwDyn (ProgramError x)
 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 -- No, man -- Too Beautiful! (Will)
 
 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
 -- No, man -- Too Beautiful! (Will)
 

-panic# :: String -> FastInt
-panic# s = case (panic s) of () -> _ILIT 0
+panicFastInt :: String -> FastInt
+panicFastInt s = case (panic s) of () -> _ILIT(0)

 
 assertPanic :: String -> Int -> a
 assertPanic file line = 
 
 assertPanic :: String -> Int -> a
 assertPanic file line = 

diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index 9c94c8e..f1051b0 100644 (file)
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -186,14 +186,17 @@ module Pretty (
 
 import BufWrite
 import FastString
 
 import BufWrite
 import FastString

-
-import GHC.Exts
+import FastTypes

 
 import Numeric (fromRat)
 import System.IO
 
 import Numeric (fromRat)
 import System.IO

+--import Foreign.Ptr (castPtr)

 
 

+#if defined(__GLASGOW_HASKELL__)
+--for a RULES

 import GHC.Base                ( unpackCString# )
 import GHC.Ptr         ( Ptr(..) )
 import GHC.Base                ( unpackCString# )
 import GHC.Ptr         ( Ptr(..) )

+#endif

 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 

@@ -203,64 +206,11 @@ infixl 5 $$, $+$
 \end{code}
 
 
 \end{code}
 
 

-
-*********************************************************
-*                                                       *
-\subsection{CPP magic so that we can compile with both GHC and Hugs}
-*                                                       *
-*********************************************************
-
-The library uses unboxed types to get a bit more speed, but these CPP macros
-allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable
-        __GLASGOW_HASKELL__
-

 \begin{code}
 
 \begin{code}
 

-#if defined(__GLASGOW_HASKELL__)
-
--- Glasgow Haskell
-

 -- Disable ASSERT checks; they are expensive!
 #define LOCAL_ASSERT(x)
 
 -- Disable ASSERT checks; they are expensive!
 #define LOCAL_ASSERT(x)
 

-#define ILIT(x) (x#)
-#define IBOX(x) (I# (x))
-#define INT     Int#
-#define MINUS   -#
-#define NEGATE  negateInt#
-#define PLUS    +#
-#define GR      >#
-#define GREQ    >=#
-#define LT      <#
-#define LTEQ    <=#
-#define DIV     `quotInt#`
-
-
-#define SHOW    Show
-#define MAXINT  maxBound
-
-#else
-
--- Standard Haskell
-
-#define LOCAL_ASSERT(x)
-
-#define INT     Int
-#define IBOX(x) x
-#define MINUS   -
-#define NEGATE  negate
-#define PLUS    +
-#define GR      >
-#define GREQ    >=
-#define LT      <
-#define DIV     `quot`
-#define ILIT(x) x
-
-#define SHOW    Show
-#define MAXINT  maxBound
-
-#endif
-

 \end{code}
 
 
 \end{code}
 
 

@@ -321,7 +271,7 @@ punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p,
 Displaying @Doc@ values. 
 
 \begin{code}
 Displaying @Doc@ values. 
 
 \begin{code}

-instance SHOW Doc where
+instance Show Doc where

   showsPrec prec doc cont = showDoc doc cont
 
 render     :: Doc -> String             -- Uses default style
   showsPrec prec doc cont = showDoc doc cont
 
 render     :: Doc -> String             -- Uses default style

@@ -491,8 +441,8 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout.
 data Doc
  = Empty                                -- empty
  | NilAbove Doc                         -- text "" $$ x
 data Doc
  = Empty                                -- empty
  | NilAbove Doc                         -- text "" $$ x

- | TextBeside !TextDetails INT Doc       -- text s <> x  
- | Nest INT Doc                         -- nest k x
+ | TextBeside !TextDetails FastInt Doc       -- text s <> x  
+ | Nest FastInt Doc                         -- nest k x

  | Union Doc Doc                        -- ul `union` ur
  | NoDoc                                -- The empty set of documents
  | Beside Doc Bool Doc                  -- True <=> space between
  | Union Doc Doc                        -- ul `union` ur
  | NoDoc                                -- The empty set of documents
  | Beside Doc Bool Doc                  -- True <=> space between

@@ -510,7 +460,7 @@ reduceDoc p              = p
 data TextDetails = Chr  {-#UNPACK#-}!Char
                  | Str  String
                  | PStr FastString     -- a hashed string
 data TextDetails = Chr  {-#UNPACK#-}!Char
                  | Str  String
                  | PStr FastString     -- a hashed string

-                | LStr Addr# Int#      -- a '\0'-terminated array of bytes
+                | LStr {-#UNPACK#-}!LitString FastInt  -- a '\0'-terminated array of bytes

 
 space_text = Chr ' '
 nl_text    = Chr '\n'
 
 space_text = Chr ' '
 nl_text    = Chr '\n'

@@ -597,24 +547,27 @@ empty = Empty
 isEmpty Empty = True
 isEmpty _     = False
 
 isEmpty Empty = True
 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 (Ptr s) = case strLength (Ptr s) of {IBOX(sl) -> textBeside_ (LStr s sl) sl Empty}
+char  c = textBeside_ (Chr c) (_ILIT(1)) Empty
+text  s = case iUnbox (length   s) of {sl -> textBeside_ (Str s)  sl Empty}
+ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty}
+ptext s_= case iUnbox (strLength s) of {sl -> textBeside_ (LStr s sl) sl Empty}
+  where s = {-castPtr-} s_

 
 

+#if defined(__GLASGOW_HASKELL__)

 -- 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 (Ptr a)
  #-}
 -- 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 (Ptr a)
  #-}

+#endif

 
 

-nest IBOX(k)  p = mkNest k (reduceDoc p)        -- Externally callable version
+nest k  p = mkNest (iUnbox k) (reduceDoc p)        -- Externally callable version

 
 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
 
 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it

-mkNest k       (Nest k1 p) = mkNest (k PLUS k1) p
+mkNest k       (Nest k1 p) = mkNest (k +# k1) p

 mkNest k       NoDoc       = NoDoc
 mkNest k       Empty       = Empty
 mkNest k       NoDoc       = NoDoc
 mkNest k       Empty       = Empty

-mkNest ILIT(0) p           = p                  -- Worth a try!
+mkNest k       p  | k ==# _ILIT(0)  = p       -- Worth a try!

 mkNest k       p           = nest_ k p
 
 -- mkUnion checks for an empty document
 mkNest k       p           = nest_ k p
 
 -- mkUnion checks for an empty document

@@ -635,10 +588,10 @@ p $+$ q = Above p True q
 
 above :: Doc -> Bool -> RDoc -> RDoc
 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 
 above :: Doc -> Bool -> RDoc -> RDoc
 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)

-above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g ILIT(0) (reduceDoc q)
-above p g q                  = aboveNest p             g ILIT(0) (reduceDoc q)
+above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g (_ILIT(0)) (reduceDoc q)
+above p g q                  = aboveNest p             g (_ILIT(0)) (reduceDoc q)

 
 

-aboveNest :: RDoc -> Bool -> INT -> RDoc -> RDoc
+aboveNest :: RDoc -> Bool -> FastInt -> RDoc -> RDoc

 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 
 aboveNest NoDoc               g k q = NoDoc
 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 
 aboveNest NoDoc               g k q = NoDoc

@@ -646,27 +599,27 @@ aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
                                       aboveNest p2 g k q
                                 
 aboveNest Empty               g k q = mkNest k q
                                       aboveNest p2 g k q
                                 
 aboveNest Empty               g k q = mkNest k q

-aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k MINUS k1) q)
+aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k -# k1) q)

                                   -- p can't be Empty, so no need for mkNest
                                 
 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
                                     where
                                   -- p can't be Empty, so no need for mkNest
                                 
 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
                                     where

-                                      k1   = k MINUS sl
+                                      k1   = k -# sl

                                       rest = case p of
                                                 Empty -> nilAboveNest g k1 q
                                                 other -> aboveNest  p g k1 q
 \end{code}
 
 \begin{code}
                                       rest = case p of
                                                 Empty -> nilAboveNest g k1 q
                                                 other -> aboveNest  p g k1 q
 \end{code}
 
 \begin{code}

-nilAboveNest :: Bool -> INT -> RDoc -> RDoc
+nilAboveNest :: Bool -> FastInt -> RDoc -> RDoc

 -- Specification: text s <> nilaboveNest g k q 
 --              = text s <> (text "" $g$ nest k q)
 
 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
 -- Specification: text s <> nilaboveNest g k q 
 --              = text s <> (text "" $g$ nest k q)
 
 nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!

-nilAboveNest g k (Nest k1 q) = nilAboveNest g (k PLUS k1) q
+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k +# k1) q

 
 

-nilAboveNest g k q           | (not g) && (k GR ILIT(0))        -- No newline if no overlap
+nilAboveNest g k q           | (not g) && (k ># _ILIT(0))        -- No newline if no overlap

                              = textBeside_ (Str (spaces k)) k q
                              | otherwise                        -- Put them really above
                              = nilAbove_ (mkNest k q)
                              = textBeside_ (Str (spaces k)) k q
                              | otherwise                        -- Put them really above
                              = nilAbove_ (mkNest k q)

@@ -711,7 +664,7 @@ nilBeside :: Bool -> RDoc -> RDoc
 
 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 nilBeside g (Nest _ p) = nilBeside g p
 
 nilBeside g Empty      = Empty  -- Hence the text "" in the spec
 nilBeside g (Nest _ p) = nilBeside g p

-nilBeside g p          | g         = textBeside_ space_text ILIT(1) p
+nilBeside g p          | g         = textBeside_ space_text (_ILIT(1)) p

                        | otherwise = p
 \end{code}
 
                        | otherwise = p
 \end{code}
 

@@ -730,24 +683,24 @@ sep = sepX True         -- Separate with spaces
 cat = sepX False        -- Don't
 
 sepX x []     = empty
 cat = sepX False        -- Don't
 
 sepX x []     = empty

-sepX x (p:ps) = sep1 x (reduceDoc p) ILIT(0) ps
+sepX x (p:ps) = sep1 x (reduceDoc p) (_ILIT(0)) ps

 
 
 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 --                            = oneLiner (x <g> nest k (hsep ys))
 --                              `union` x $$ nest k (vcat ys)
 
 
 
 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 --                            = oneLiner (x <g> nest k (hsep ys))
 --                              `union` x $$ nest k (vcat ys)
 

-sep1 :: Bool -> RDoc -> INT -> [Doc] -> RDoc
+sep1 :: Bool -> RDoc -> FastInt -> [Doc] -> RDoc

 sep1 g NoDoc               k ys = NoDoc
 sep1 g (p `Union` q)       k ys = sep1 g p k ys
                                   `union_`
                                   (aboveNest q False k (reduceDoc (vcat ys)))
 
 sep1 g Empty               k ys = mkNest k (sepX g ys)
 sep1 g NoDoc               k ys = NoDoc
 sep1 g (p `Union` q)       k ys = sep1 g p k ys
                                   `union_`
                                   (aboveNest q False k (reduceDoc (vcat ys)))
 
 sep1 g Empty               k ys = mkNest k (sepX g ys)

-sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k MINUS n) ys)
+sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k -# n) ys)

 
 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
 
 sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))

-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k MINUS sl) ys)
+sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k -# sl) ys)

 
 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 -- Called when we have already found some text in the first item
 
 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 -- Called when we have already found some text in the first item

@@ -784,20 +737,20 @@ fcat = fill False
 --                      p1 $$ fill ps
 
 fill g []     = empty
 --                      p1 $$ fill ps
 
 fill g []     = empty

-fill g (p:ps) = fill1 g (reduceDoc p) ILIT(0) ps
+fill g (p:ps) = fill1 g (reduceDoc p) (_ILIT(0)) ps

 
 
 
 

-fill1 :: Bool -> RDoc -> INT -> [Doc] -> Doc
+fill1 :: Bool -> RDoc -> FastInt -> [Doc] -> Doc

 fill1 g NoDoc               k ys = NoDoc
 fill1 g (p `Union` q)       k ys = fill1 g p k ys
                                    `union_`
                                    (aboveNest q False k (fill g ys))
 
 fill1 g Empty               k ys = mkNest k (fill g ys)
 fill1 g NoDoc               k ys = NoDoc
 fill1 g (p `Union` q)       k ys = fill1 g p k ys
                                    `union_`
                                    (aboveNest q False k (fill g ys))
 
 fill1 g Empty               k ys = mkNest k (fill g ys)

-fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k MINUS n) ys)
+fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k -# n) ys)

 
 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
 
 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))

-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k MINUS sl) ys)
+fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k -# sl) ys)

 
 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 fillNB g Empty k []        = Empty
 
 fillNB g (Nest _ p)  k ys  = fillNB g p k ys
 fillNB g Empty k []        = Empty

@@ -805,7 +758,7 @@ fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys
                              `mkUnion` 
                              nilAboveNest False k (fill g (y:ys))
                            where
                              `mkUnion` 
                              nilAboveNest False k (fill g (y:ys))
                            where

-                             k1 | g         = k MINUS ILIT(1)
+                             k1 | g         = k -# _ILIT(1)

                                 | otherwise = k
 
 fillNB g p k ys            = fill1 g p k ys
                                 | otherwise = k
 
 fillNB g p k ys            = fill1 g p k ys

@@ -824,47 +777,45 @@ best :: Int             -- Line length
      -> RDoc
      -> RDoc            -- No unions in here!
 
      -> RDoc
      -> RDoc            -- No unions in here!
 

-best IBOX(w) IBOX(r) p
-  = get w p
+best w_ r_ p
+  = get (iUnbox w_) p

   where
   where

-    get :: INT          -- (Remaining) width of line
+    r = iUnbox r_
+    get :: FastInt          -- (Remaining) width of line

         -> Doc -> Doc
     get w Empty               = Empty
     get w NoDoc               = NoDoc
     get w (NilAbove p)        = nilAbove_ (get w p)
     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
         -> Doc -> Doc
     get w Empty               = Empty
     get w NoDoc               = NoDoc
     get w (NilAbove p)        = nilAbove_ (get w p)
     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)

-    get w (Nest k p)          = nest_ k (get (w MINUS k) p)
+    get w (Nest k p)          = nest_ k (get (w -# k) p)

     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 
     get w (p `Union` q)       = nicest w r (get w p) (get w q)
 

-    get1 :: INT         -- (Remaining) width of line
-         -> INT         -- Amount of first line already eaten up
+    get1 :: FastInt         -- (Remaining) width of line
+         -> FastInt         -- Amount of first line already eaten up

          -> Doc         -- This is an argument to TextBeside => eat Nests
          -> Doc         -- No unions in here!
 
     get1 w sl Empty               = Empty
     get1 w sl NoDoc               = NoDoc
          -> Doc         -- This is an argument to TextBeside => eat Nests
          -> Doc         -- No unions in here!
 
     get1 w sl Empty               = Empty
     get1 w sl NoDoc               = NoDoc

-    get1 w sl (NilAbove p)        = nilAbove_ (get (w MINUS sl) p)
-    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl PLUS tl) p)
+    get1 w sl (NilAbove p)        = nilAbove_ (get (w -# sl) p)
+    get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl +# tl) p)

     get1 w sl (Nest k p)          = get1 w sl p
     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p) 
                                                    (get1 w sl q)
 
     get1 w sl (Nest k p)          = get1 w sl p
     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p) 
                                                    (get1 w sl q)
 

-nicest w r p q = nicest1 w r ILIT(0) p q
-nicest1 w r sl p q | fits ((w `minn` r) MINUS sl) p = p
+nicest w r p q = nicest1 w r (_ILIT(0)) p q
+nicest1 w r sl p q | fits ((w `minFastInt` r) -# sl) p = p

                    | otherwise                   = q
 
                    | otherwise                   = q
 

-fits :: INT     -- Space available
+fits :: FastInt     -- Space available

      -> Doc
      -> Bool    -- True if *first line* of Doc fits in space available
  
      -> Doc
      -> Bool    -- True if *first line* of Doc fits in space available
  

-fits n p    | n LT ILIT(0) = False
+fits n p   | n <# _ILIT(0) = False

 fits n NoDoc               = False
 fits n Empty               = True
 fits n (NilAbove _)        = True
 fits n NoDoc               = False
 fits n Empty               = True
 fits n (NilAbove _)        = True

-fits n (TextBeside _ sl p) = fits (n MINUS sl) p
-
-minn x y | x LT y    = x
-         | otherwise = y
+fits n (TextBeside _ sl p) = fits (n -# sl) p

 \end{code}
 
 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
 \end{code}
 
 @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.

@@ -922,15 +873,6 @@ string_txt (Chr c)   s  = c:s
 string_txt (Str s1)  s2 = s1 ++ s2
 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
 string_txt (Str s1)  s2 = s1 ++ s2
 string_txt (PStr s1) s2 = unpackFS s1 ++ s2
 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2

-
-unpackLitString addr =
- unpack 0#
- where
-    unpack nh
-      | ch `eqChar#` '\0'# = []
-      | otherwise   = C# ch : unpack (nh +# 1#)
-      where
-       ch = indexCharOffAddr# addr nh

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -962,55 +904,55 @@ fullRender mode line_length ribbons_per_line txt end doc
 
     hacked_line_length, ribbon_length :: Int
     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
 
     hacked_line_length, ribbon_length :: Int
     ribbon_length = round (fromIntegral line_length / ribbons_per_line)

-    hacked_line_length = case mode of { ZigZagMode -> MAXINT; other -> line_length }
+    hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }

 
 

-display mode IBOX(page_width) IBOX(ribbon_width) txt end doc
-  = case page_width MINUS ribbon_width of { gap_width ->
-    case gap_width DIV ILIT(2) of { shift ->
+display mode page_width ribbon_width txt end doc
+  = case (iUnbox page_width) -# (iUnbox ribbon_width) of { gap_width ->
+    case gap_width `quotFastInt` _ILIT(2) of { shift ->

     let
     let

-        lay k (Nest k1 p)  = lay (k PLUS k1) p
+        lay k (Nest k1 p)  = lay (k +# k1) p

         lay k Empty        = end
     
         lay k (NilAbove p) = nl_text `txt` lay k p
     
         lay k (TextBeside s sl p)
             = case mode of
         lay k Empty        = end
     
         lay k (NilAbove p) = nl_text `txt` lay k p
     
         lay k (TextBeside s sl p)
             = case mode of

-                    ZigZagMode |  k GREQ gap_width
+                    ZigZagMode |  k >=# gap_width

                                -> nl_text `txt` (
                                   Str (multi_ch shift '/') `txt` (
                                   nl_text `txt` (
                                -> nl_text `txt` (
                                   Str (multi_ch shift '/') `txt` (
                                   nl_text `txt` (

-                                  lay1 (k MINUS shift) s sl p)))
+                                  lay1 (k -# shift) s sl p)))

 
 

-                               |  k LT ILIT(0)
+                               |  k <# _ILIT(0)

                                -> nl_text `txt` (
                                   Str (multi_ch shift '\\') `txt` (
                                   nl_text `txt` (
                                -> nl_text `txt` (
                                   Str (multi_ch shift '\\') `txt` (
                                   nl_text `txt` (

-                                  lay1 (k PLUS shift) s sl p )))
+                                  lay1 (k +# shift) s sl p )))

 
                     other -> lay1 k s sl p
     
 
                     other -> lay1 k s sl p
     

-        lay1 k s sl p = indent k (s `txt` lay2 (k PLUS sl) p)
+        lay1 k s sl p = indent k (s `txt` lay2 (k +# sl) p)

     
         lay2 k (NilAbove p)        = nl_text `txt` lay k p
     
         lay2 k (NilAbove p)        = nl_text `txt` lay k p

-        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k PLUS sl) p)
+        lay2 k (TextBeside s sl p) = s `txt` (lay2 (k +# sl) p)

         lay2 k (Nest _ p)          = lay2 k p
         lay2 k Empty               = end
 
         -- optimise long indentations using LitString chunks of 8 spaces
         lay2 k (Nest _ p)          = lay2 k p
         lay2 k Empty               = end
 
         -- optimise long indentations using LitString chunks of 8 spaces

-        indent n r | n GREQ ILIT(8) = LStr "        "# 8# `txt` 
-                                      indent (n MINUS ILIT(8)) r
+        indent n r | n >=# _ILIT(8) = LStr SLIT("        ") (_ILIT(8)) `txt` 
+                                      indent (n -# _ILIT(8)) r

                    | otherwise      = Str (spaces n) `txt` r
     in
                    | otherwise      = Str (spaces n) `txt` r
     in

-    lay ILIT(0) doc
+    lay (_ILIT(0)) doc

     }}
 
 cant_fail = error "easy_display: NoDoc"
 
     }}
 
 cant_fail = error "easy_display: NoDoc"
 

-multi_ch n ch | n LTEQ ILIT(0) = ""
-             | otherwise      = ch : multi_ch (n MINUS ILIT(1)) ch
+multi_ch n ch | n <=# _ILIT(0) = ""
+             | otherwise      = ch : multi_ch (n -# _ILIT(1)) ch

 
 

-spaces n | n LTEQ ILIT(0) = ""
-         | otherwise      = ' ' : spaces (n MINUS ILIT(1))
+spaces n | n <=# _ILIT(0) = ""
+         | otherwise      = ' ' : spaces (n -# _ILIT(1))

 
 \end{code}
 
 
 \end{code}
 

@@ -1032,9 +974,9 @@ printDoc mode hdl doc
     done = hPutChar hdl '\n'
 
   -- some versions of hPutBuf will barf if the length is zero
     done = hPutChar hdl '\n'
 
   -- some versions of hPutBuf will barf if the length is zero

-hPutLitString handle a# 0# = return ()
-hPutLitString handle a# l#
-  = hPutBuf handle (Ptr a#) (I# l#)
+hPutLitString handle a l = if l ==# _ILIT(0)
+                            then return ()
+                            else hPutBuf handle a (iBox l)

 
 -- Printing output in LeftMode is performance critical: it's used when
 -- dumping C and assembly output, so we allow ourselves a few dirty
 
 -- Printing output in LeftMode is performance critical: it's used when
 -- dumping C and assembly output, so we allow ourselves a few dirty

diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs
index 92a937b..0b0874a 100644 (file)
--- a/compiler/utils/StringBuffer.lhs
+++ b/compiler/utils/StringBuffer.lhs
@@ -47,22 +47,22 @@ module StringBuffer
 
 import Encoding
 import FastString              ( FastString,mkFastString,mkFastStringBytes )
 
 import Encoding
 import FastString              ( FastString,mkFastString,mkFastStringBytes )

+import FastTypes
+import FastFunctions

 
 import Foreign
 import System.IO               ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
                                 , Handle, hTell )
 
 import GHC.Exts
 
 import Foreign
 import System.IO               ( hGetBuf, hFileSize,IOMode(ReadMode), hClose
                                 , Handle, hTell )
 
 import GHC.Exts

-import GHC.IOBase              ( IO(..) )
-import GHC.Base                        ( unsafeChr )

 
 

-#if __GLASGOW_HASKELL__ >= 601
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601

 import System.IO               ( openBinaryFile )
 #else
 import IOExts                   ( openFileEx, IOModeEx(..) )
 #endif
 
 import System.IO               ( openBinaryFile )
 #else
 import IOExts                   ( openFileEx, IOModeEx(..) )
 #endif
 

-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601

 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
 #endif
 
 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
 #endif
 

@@ -216,28 +216,28 @@ lexemeToFastString (StringBuffer buf _ cur) len =
 
 -- -----------------------------------------------------------------------------
 -- Parsing integer strings in various bases
 
 -- -----------------------------------------------------------------------------
 -- Parsing integer strings in various bases

-
+{-

 byteOff :: StringBuffer -> Int -> Char
 byteOff (StringBuffer buf _ cur) i = 
   inlinePerformIO $ withForeignPtr buf $ \ptr -> do
 byteOff :: StringBuffer -> Int -> Char
 byteOff (StringBuffer buf _ cur) i = 
   inlinePerformIO $ withForeignPtr buf $ \ptr -> do

-    w <- peek (ptr `plusPtr` (cur+i))
-    return (unsafeChr (fromIntegral (w::Word8)))
-
+--    return $! cBox (indexWord8OffFastPtrAsFastChar
+--                         (pUnbox ptr) (iUnbox (cur+i)))
+--or
+--    w <- peek (ptr `plusPtr` (cur+i))
+--    return (unsafeChr (fromIntegral (w::Word8)))
+-}

 -- | XXX assumes ASCII digits only (by using byteOff)
 parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer
 -- | XXX assumes ASCII digits only (by using byteOff)
 parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer

-parseUnsignedInteger buf len radix char_to_int 
-  = go 0 0
-  where
+parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int 
+  = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let
+    --LOL, in implementations where the indexing needs slow unsafePerformIO,
+    --this is less (not more) efficient than using the IO monad explicitly
+    --here.
+    byteOff p i = cBox (indexWord8OffFastPtrAsFastChar
+                         (pUnbox ptr) (iUnbox (cur+i)))

     go i x | i == len  = x
     go i x | i == len  = x

-           | otherwise = go (i+1)
-              (x * radix + toInteger (char_to_int (byteOff buf i)))
-
--- -----------------------------------------------------------------------------
--- under the carpet
-
--- Just like unsafePerformIO, but we inline it.
-{-# INLINE inlinePerformIO #-}
-inlinePerformIO :: IO a -> a
-inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
+           | otherwise = case byteOff ptr i of
+               char -> go (i+1) (x * radix + toInteger (char_to_int char))
+  in go 0 0

 
 \end{code}
 
 \end{code}

diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 2184f52..59158f3 100644 (file)
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -51,12 +51,10 @@ module UniqFM (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import Unique          ( Uniquable(..), Unique, getKey#, mkUniqueGrimily )
+import Unique          ( Uniquable(..), Unique, getKeyFastInt, mkUniqueGrimily )

 import Maybes          ( maybeToBool )
 import FastTypes
 import Outputable
 import Maybes          ( maybeToBool )
 import FastTypes
 import Outputable

-
-import GHC.Exts                -- Lots of Int# operations

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -237,8 +235,8 @@ First the ways of building a UniqFM.
 
 \begin{code}
 emptyUFM                    = EmptyUFM
 
 \begin{code}
 emptyUFM                    = EmptyUFM

-unitUFM             key elt = mkLeafUFM (getKey# (getUnique key)) elt
-unitDirectlyUFM key elt = mkLeafUFM (getKey# key) elt
+unitUFM             key elt = mkLeafUFM (getKeyFastInt (getUnique key)) elt
+unitDirectlyUFM key elt = mkLeafUFM (getKeyFastInt key) elt

 
 listToUFM key_elt_pairs
   = addListToUFM_C use_snd EmptyUFM key_elt_pairs
 
 listToUFM key_elt_pairs
   = addListToUFM_C use_snd EmptyUFM key_elt_pairs

@@ -257,13 +255,13 @@ could be optimised using it.
 \begin{code}
 addToUFM fm key elt = addToUFM_C use_snd fm key elt
 
 \begin{code}
 addToUFM fm key elt = addToUFM_C use_snd fm key elt
 

-addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt
+addToUFM_Directly fm u elt = insert_ele use_snd fm (getKeyFastInt u) elt

 
 addToUFM_C combiner fm key elt
 
 addToUFM_C combiner fm key elt

-  = insert_ele combiner fm (getKey# (getUnique key)) elt
+  = insert_ele combiner fm (getKeyFastInt (getUnique key)) elt

 
 addToUFM_Acc add unit fm key item
 
 addToUFM_Acc add unit fm key item

-  = insert_ele combiner fm (getKey# (getUnique key)) (unit item)
+  = insert_ele combiner fm (getKeyFastInt (getUnique key)) (unit item)

   where
     combiner old _unit_item = add item old
 
   where
     combiner old _unit_item = add item old
 

@@ -271,12 +269,12 @@ addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
 
 addListToUFM_C combiner fm key_elt_pairs
 addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
 
 addListToUFM_C combiner fm key_elt_pairs

- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# (getUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt (getUnique k)) e)

         fm key_elt_pairs
 
 addListToUFM_directly_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Unique,elt)] -> UniqFM elt
 addListToUFM_directly_C combiner fm uniq_elt_pairs
         fm key_elt_pairs
 
 addListToUFM_directly_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Unique,elt)] -> UniqFM elt
 addListToUFM_directly_C combiner fm uniq_elt_pairs

- = foldl (\ fm (k, e) -> insert_ele combiner fm (getKey# k) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (getKeyFastInt k) e)

         fm uniq_elt_pairs
 \end{code}
 
         fm uniq_elt_pairs
 \end{code}
 

@@ -285,10 +283,10 @@ Now ways of removing things from UniqFM.
 \begin{code}
 delListFromUFM fm lst = foldl delFromUFM fm lst
 
 \begin{code}
 delListFromUFM fm lst = foldl delFromUFM fm lst
 

-delFromUFM          fm key = delete fm (getKey# (getUnique key))
-delFromUFM_Directly fm u   = delete fm (getKey# u)
+delFromUFM          fm key = delete fm (getKeyFastInt (getUnique key))
+delFromUFM_Directly fm u   = delete fm (getKeyFastInt u)

 
 

-delete :: UniqFM a -> Int# -> UniqFM a
+delete :: UniqFM a -> FastInt -> UniqFM a

 delete EmptyUFM _   = EmptyUFM
 delete fm       key = del_ele fm
   where
 delete EmptyUFM _   = EmptyUFM
 delete fm       key = del_ele fm
   where

@@ -539,9 +537,7 @@ mapUFM _fn EmptyUFM   = EmptyUFM
 mapUFM  fn fm        = map_tree fn fm
 
 filterUFM _fn EmptyUFM = EmptyUFM
 mapUFM  fn fm        = map_tree fn fm
 
 filterUFM _fn EmptyUFM = EmptyUFM

-filterUFM  fn fm       = filter_tree pred fm
-       where
-         pred (_::FastInt) e = fn e
+filterUFM  fn fm       = filter_tree (\_ e -> fn e) fm

 
 filterUFM_Directly _fn EmptyUFM = EmptyUFM
 filterUFM_Directly  fn fm       = filter_tree pred fm
 
 filterUFM_Directly _fn EmptyUFM = EmptyUFM
 filterUFM_Directly  fn fm       = filter_tree pred fm

@@ -576,20 +572,20 @@ Lookup up a binary tree is easy (and fast).
 elemUFM          key fm = maybeToBool (lookupUFM fm key)
 elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
 
 elemUFM          key fm = maybeToBool (lookupUFM fm key)
 elemUFM_Directly key fm = maybeToBool (lookupUFM_Directly fm key)
 

-lookupUFM         fm key = lookUp fm (getKey# (getUnique key))
-lookupUFM_Directly fm key = lookUp fm (getKey# key)
+lookupUFM         fm key = lookUp fm (getKeyFastInt (getUnique key))
+lookupUFM_Directly fm key = lookUp fm (getKeyFastInt key)

 
 lookupWithDefaultUFM fm deflt key
 
 lookupWithDefaultUFM fm deflt key

-  = case lookUp fm (getKey# (getUnique key)) of
+  = case lookUp fm (getKeyFastInt (getUnique key)) of

       Nothing  -> deflt
       Just elt -> elt
 
 lookupWithDefaultUFM_Directly fm deflt key
       Nothing  -> deflt
       Just elt -> elt
 
 lookupWithDefaultUFM_Directly fm deflt key

-  = case lookUp fm (getKey# key) of
+  = case lookUp fm (getKeyFastInt key) of

       Nothing  -> deflt
       Just elt -> elt
 
       Nothing  -> deflt
       Just elt -> elt
 

-lookUp :: UniqFM a -> Int# -> Maybe a
+lookUp :: UniqFM a -> FastInt -> Maybe a

 lookUp EmptyUFM _   = Nothing
 lookUp fm i        = lookup_tree fm
   where
 lookUp EmptyUFM _   = Nothing
 lookUp fm i        = lookup_tree fm
   where

@@ -787,10 +783,7 @@ This specifies the relationship between NodeUFMData and CalcNodeUFMData.
 indexToRoot :: FastInt -> NodeUFMData
 
 indexToRoot i
 indexToRoot :: FastInt -> NodeUFMData
 
 indexToRoot i

-  = let
-       l = (_ILIT(1) :: FastInt)
-    in
-    NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l
+  = NodeUFMData ((shiftL1 (shiftR1 i)) +# _ILIT(1)) (_ILIT(1))

 
 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
 
 
 getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData
 

@@ -799,17 +792,16 @@ getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
   | p <# p2    = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
   | otherwise  = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
   where
   | p <# p2    = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
   | otherwise  = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
   where

-    l  = (_ILIT(1) :: FastInt)
-    j  = i  `quotFastInt` (p  `shiftL_` l)
-    j2 = i2 `quotFastInt` (p2 `shiftL_` l)
+    j  = i  `quotFastInt` (shiftL1 p)
+    j2 = i2 `quotFastInt` (shiftL1 p2)

 
     getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
 
     getCommonNodeUFMData_ p j j_
       | j ==# j_
 
     getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
 
     getCommonNodeUFMData_ p j j_
       | j ==# j_

-      = NodeUFMData (((j `shiftL_` l) +# l) *# p) p
+      = NodeUFMData (((shiftL1 j) +# _ILIT(1)) *# p) p

       | otherwise
       | otherwise

-      = getCommonNodeUFMData_ (p `shiftL_`  l) (j `shiftR_` l) (j_ `shiftR_` l)
+      = getCommonNodeUFMData_ (shiftL1 p) (shiftR1 j) (shiftR1 j_)

 
 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
 
 
 ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot
 

@@ -832,20 +824,14 @@ This might be better in Util.lhs ?
 
 Now the bit twiddling functions.
 \begin{code}
 
 Now the bit twiddling functions.
 \begin{code}

-shiftL_ :: FastInt -> FastInt -> FastInt
-shiftR_ :: FastInt -> FastInt -> FastInt
-
-#if __GLASGOW_HASKELL__
-{-# INLINE shiftL_ #-}
-{-# INLINE shiftR_ #-}
-shiftL_ n p = word2Int#((int2Word# n) `uncheckedShiftL#` p)
-shiftR_ n p = word2Int#((int2Word# n) `uncheckedShiftRL#` p)
+shiftL1 :: FastInt -> FastInt
+shiftR1 :: FastInt -> FastInt

 
 

-#else /* not GHC */
-shiftL_ n p = n * (2 ^ p)
-shiftR_ n p = n `quot` (2 ^ p)
+{-# INLINE shiftL1 #-}
+{-# INLINE shiftR1 #-}

 
 

-#endif /* not GHC */
+shiftL1 n = n `shiftLFastInt` _ILIT(1)
+shiftR1 n = n `shiftR_FastInt` _ILIT(1)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs
index 9b61454..08d3575 100644 (file)
--- a/compiler/utils/UniqSet.lhs
+++ b/compiler/utils/UniqSet.lhs
@@ -116,7 +116,7 @@ mapUniqSet f (MkUniqSet set) = MkUniqSet (mapUFM f set)
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-#if __GLASGOW_HASKELL__
+#ifdef __GLASGOW_HASKELL__

 {-# SPECIALIZE
     addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique
     #-}
 {-# SPECIALIZE
     addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique
     #-}

diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 852bb90..01685f3 100644 (file)
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -331,21 +331,21 @@ notElem__ x (y:ys) = x /= y && notElem__ x ys
 
 # else /* DEBUG */
 isIn msg x ys
 
 # else /* DEBUG */
 isIn msg x ys

-  = elem (_ILIT 0) x ys
+  = elem (_ILIT(0)) x ys

   where
     elem _ _ []        = False
     elem i x (y:ys)
   where
     elem _ _ []        = False
     elem i x (y:ys)

-      | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg)
-                               (x `List.elem` (y:ys))
-      | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
+      | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
+                                (x `List.elem` (y:ys))
+      | otherwise       = x == y || elem (i +# _ILIT(1)) x ys

 
 isn'tIn msg x ys
 
 isn'tIn msg x ys

-  = notElem (_ILIT 0) x ys
+  = notElem (_ILIT(0)) x ys

   where
     notElem _ _ [] =  True
     notElem i x (y:ys)
   where
     notElem _ _ [] =  True
     notElem i x (y:ys)

-      | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg)
-                               (x `List.notElem` (y:ys))
+      | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
+                                (x `List.notElem` (y:ys))

       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 # endif /* DEBUG */
 \end{code}
       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 # endif /* DEBUG */
 \end{code}

@@ -353,7 +353,7 @@ isn'tIn msg x ys
 foldl1' was added in GHC 6.4
 
 \begin{code}
 foldl1' was added in GHC 6.4
 
 \begin{code}

-#if __GLASGOW_HASKELL__ < 604
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604

 foldl1'          :: (a -> a -> a) -> [a] -> a
 foldl1' f (x:xs) =  foldl' f x xs
 foldl1' _ []     =  panic "foldl1'"
 foldl1'          :: (a -> a -> a) -> [a] -> a
 foldl1' f (x:xs) =  foldl' f x xs
 foldl1' _ []     =  panic "foldl1'"