diff options
| author | Isaac Dupree <id@isaac.cedarswampstudios.org> | 2008-01-17 01:13:12 +0000 |
|---|---|---|
| committer | Isaac Dupree <id@isaac.cedarswampstudios.org> | 2008-01-17 01:13:12 +0000 |
| commit | 206b4dec78250efef3cd927d64dc6cbc54a16c3d (patch) | |
| tree | 5c922e32a60500a0935e4bf378bb0bdd7819fef0 | |
| parent | 1286da96dc65faa5992a8a34c5b3bf29dfe2be04 (diff) | |
| download | haskell-206b4dec78250efef3cd927d64dc6cbc54a16c3d.tar.gz | |
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
47 files changed, 720 insertions, 419 deletions
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index add588d8b8..dcab3c189a 100644 --- 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" -#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 -#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 #-} @@ -64,8 +66,13 @@ name = Util.global (value) :: IORef (ty); \ import qualified FastString as FS #endif +#if defined(__GLASGOW_HASKELL__) #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 diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index c6782f0ad9..ec1d7c473b 100644 --- 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 -#if __GLASGOW_HASKELL__ +#ifdef __GLASGOW_HASKELL__ 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 c6e7d25aca..489527e266 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -54,11 +54,11 @@ import Unique import Maybes import Binary import FastMutInt +import FastTypes import FastString import Outputable import Data.IORef -import GHC.Exts 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 - 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 } @@ -136,7 +137,7 @@ nameModule :: Name -> Module 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 @@ -193,7 +194,7 @@ isSystemName other = False \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 @@ -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 - = 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 - = 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 -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 @@ -227,17 +228,17 @@ mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) 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 - = 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 - = Name { n_uniq = getKey# uniq, + = Name { n_uniq = getKeyFastInt uniq, 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 -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 @@ -284,7 +285,7 @@ hashName name = getKey (nameUnique name) + 1 %************************************************************************ \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} @@ -347,14 +348,14 @@ instance Outputable Name where 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 - 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 diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index d597a46f34..8298f5965d 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -82,6 +82,7 @@ import StaticFlags import UniqFM import UniqSet import FastString +import FastTypes import Outputable import Binary @@ -89,7 +90,7 @@ import GHC.Exts 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 @@ -255,7 +256,7 @@ easy to build an OccEnv. \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' diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index c228eeb570..d28372adb3 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -31,20 +31,16 @@ module UniqSupply ( #include "HsVersions.h" import Unique - -import GHC.Exts -import System.IO.Unsafe ( unsafeInterleaveIO ) +import FastTypes #if __GLASGOW_HASKELL__ >= 607 import GHC.IOBase (unsafeDupableInterleaveIO) #else +import System.IO.Unsafe ( unsafeInterleaveIO ) unsafeDupableInterleaveIO :: IO a -> IO a unsafeDupableInterleaveIO = unsafeInterleaveIO #endif -w2i x = word2Int# x -i2w x = int2Word# x -i2w_s x = (x :: Int#) \end{code} @@ -61,7 +57,7 @@ which will be distinct from the first and from all others. \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} @@ -76,21 +72,21 @@ uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite \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 - mk_supply# + mk_supply = 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 @@ -99,8 +95,8 @@ listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 \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} %************************************************************************ diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 5f9f66834f..ee21a0df69 100644 --- 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! - getKey, getKey#, -- Used in Var, UniqFM, Name only! + getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only! incrUnique, -- Used for renumbering deriveUnique, -- Ditto @@ -59,10 +59,16 @@ module Unique ( import StaticFlags import BasicTypes +import FastTypes 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} @@ -76,7 +82,8 @@ The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. 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. @@ -88,7 +95,7 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse 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 @@ -99,18 +106,18 @@ isTupleKey :: Unique -> Bool \begin{code} -mkUniqueGrimily (I# x) = MkUnique x +mkUniqueGrimily x = MkUnique (iUnbox x) {-# 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 (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 @@ -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 -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 - 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 - 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} @@ -153,7 +160,7 @@ hasKey :: Uniquable a => a -> Unique -> Bool 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 @@ -238,17 +245,28 @@ Code stolen from Lennart. \begin{code} iToBase62 :: Int -> String -iToBase62 n@(I# n#) - = ASSERT(n >= 0) go n# "" +iToBase62 n_ + = ASSERT(n_ >= 0) go (iUnbox n_) "" 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 - = 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} %************************************************************************ diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index e66286ee82..5b3097da7d 100644 --- 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 - = var { realUnique = getKey# uniq, + = var { realUnique = getKeyFastInt uniq, 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} @@ -199,7 +199,7 @@ setTyVarKind tv k = tv {varType = k} 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 } @@ -209,7 +209,7 @@ mkTcTyVar name kind details = -- TOM: no longer valid assertion? -- ASSERT( not (isCoercionKind kind) ) TcTyVar { varName = name, - realUnique = getKey# (nameUnique name), + realUnique = getKeyFastInt (nameUnique name), varType = kind, tcTyVarDetails = details } @@ -232,7 +232,7 @@ setCoVarName = setVarName 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 @@ -330,7 +330,7 @@ maybeModifyIdInfo Nothing id = id 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 } @@ -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, - realUnique = getKey# (nameUnique name), -- Cache the unique + realUnique = getKeyFastInt (nameUnique name), -- Cache the unique varType = ty, lclDetails = details, idInfo_ = info } diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index f3a093aed8..d65ec5face 100644 --- 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 -emptyInScopeSet = InScope emptyVarSet 1# +emptyInScopeSet = InScope emptyVarSet (_ILIT(1)) 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 (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 @@ -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 (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 @@ -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 - = try 1# + = try (_ILIT(1)) 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 - | uniq `elemVarSetByKey` set = try (k +# 1#) + | uniq `elemVarSetByKey` set = try (k +# _ILIT(1)) #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 diff --git a/compiler/cbits/rawSystem.c b/compiler/cbits/rawSystem.c index d103f4808b..3ef37e56e4 100644 --- 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. */ -#if __GLASGOW_HASKELL__ < 601 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 #include "../../libraries/base/cbits/rawSystem.c" #endif diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index c906050a1b..a6cf27f9e2 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -30,13 +30,12 @@ import StaticFlags import UniqFM import Unique - +import FastTypes import Outputable import Data.Bits import Data.Word import Data.Int -import GHC.Exts -- ----------------------------------------------------------------------------- -- 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. -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 x - = if (x <= 0 || x >= 2147483648) then +exactLog2 x_ + = if (x_ <= 0 || x_ >= 2147483648) then 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 - Just (toInteger (I# (pow2 x#))) + Just (toInteger (iBox (pow2 x))) } 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 49f8b055be..6e05cdc68b 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -11,7 +11,7 @@ module OptimizationFuel ) where -import GHC.Exts (State#) +--import GHC.Exts (State#) import Panic import Data.IORef @@ -49,7 +49,7 @@ diffFuel _ _ = 0 #endif -- stop warnings about things that aren't used -_unused :: State# () -> FS.FastString +_unused :: {-State#-} () -> FS.FastString _unused = undefined panic diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 9d71b73422..9617c5999c 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -57,7 +57,6 @@ import Bag import FastTypes import Outputable -import GHC.Exts ( Int# ) \end{code} @@ -182,7 +181,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr \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 @@ -242,7 +241,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr 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: @@ -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 - = 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 @@ -335,7 +334,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr ------------ -- 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 ------------ @@ -373,12 +372,12 @@ maxSize _ TooBig = TooBig 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 - | 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, @@ -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 -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 @@ -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. -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 -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) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 716298223f..e97ab4252c 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -29,7 +29,7 @@ import FiniteMap 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 ) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 4fcf6025b7..b9f09974a5 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -685,7 +685,7 @@ data ResType name \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 diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index c8ce17ee95..7683faef5f 100644 --- 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]) -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")], - 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")], @@ -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 -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 diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index 8d86582efe..60d1410cd0 100644 --- 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 -- +-- 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 -- ----------------------------------------------------------------------------- @@ -15,15 +19,19 @@ -- for details module BreakArray - ( BreakArray (BA) - -- constructor is exported only for ByteCodeGen + ( BreakArray +#ifdef GHCI + (BA) -- constructor is exported only for ByteCodeGen +#endif , newBreakArray +#ifdef GHCI , getBreak , setBreakOn , setBreakOff , showBreakArray +#endif ) where - +#ifdef GHCI 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 + +#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 e4559d4a04..d02582efed 100644 --- 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 -#if __GLASGOW_HASKELL__ < 603 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 typeOf _ = mkAppTy errMsgTc [] #else typeOf _ = mkTyConApp errMsgTc [] diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 7142645435..5d6e41ca8d 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -46,13 +46,13 @@ import System.Exit 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 -#if __GLASGOW_HASKELL__ < 601 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 openBinaryFile fp mode = openFileEx fp (BinaryMode mode) #endif diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 7f7fab8635..7ad34ace63 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1484,7 +1484,9 @@ data Unlinked | BCOs CompiledByteCode ModBreaks #ifndef GHCI -data CompiledByteCode +data CompiledByteCode = CompiledByteCodeUndefined +_unused :: CompiledByteCode +_unused = CompiledByteCodeUndefined #endif instance Outputable Unlinked where diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d5cfbd1098..749b91e0e6 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -54,7 +54,7 @@ import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable -#if __GLASGOW_HASKELL__ < 603 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 import Compat.Directory ( getAppUserDataDirectory ) #endif diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 41421d6411..2df9a72407 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -72,7 +72,7 @@ import Foreign 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 ) @@ -480,7 +480,7 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- 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 @@ -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 diff --git a/compiler/nativeGen/MachRegs.lhs b/compiler/nativeGen/MachRegs.lhs index 522f7153c4..85c88b2ed3 100644 --- a/compiler/nativeGen/MachRegs.lhs +++ b/compiler/nativeGen/MachRegs.lhs @@ -103,11 +103,10 @@ import qualified Outputable import Unique import UniqSet import Constants +import FastTypes import FastBool import UniqFM -import GHC.Exts - #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 -#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 -#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 -#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 #-} @@ -535,17 +534,17 @@ trivColorable classN conflicts exclusions LeafUFM _ reg -> case regClass reg of RcInteger - -> case cI +# 1# of + -> case cI +# _ILIT(1) of 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 #) - 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 diff --git a/compiler/nativeGen/RegAllocColor.hs b/compiler/nativeGen/RegAllocColor.hs index 60c35a3579..51a0bffbc6 100644 --- 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 ) -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 diff --git a/compiler/nativeGen/RegAllocInfo.hs b/compiler/nativeGen/RegAllocInfo.hs index b6b2a73b7c..d834a80e99 100644 --- a/compiler/nativeGen/RegAllocInfo.hs +++ b/compiler/nativeGen/RegAllocInfo.hs @@ -814,7 +814,7 @@ mkSpillInstr reg delta slot 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 diff --git a/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y index e3f45f9475..d46223ddb3 100644 --- a/compiler/parser/HaddockParse.y +++ b/compiler/parser/HaddockParse.y @@ -9,7 +9,7 @@ module HaddockParse ( parseHaddockParagraphs, parseHaddockString, - MyEither(..) + EitherString(..) ) where import {-# SOURCE #-} HaddockLex @@ -35,7 +35,7 @@ import RdrName PARA { TokPara } STRING { TokString $$ } -%monad { MyEither String } +%monad { EitherString } %name parseHaddockParagraphs doc %name parseHaddockString seq @@ -98,15 +98,18 @@ strings :: { String } | 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 -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 diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 57f5deb6a1..b9014b2927 100644 --- 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 - 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 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 508bea6459..66177a90aa 100644 --- 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))) - 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) diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index b03f50a890..5fba8c35fa 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -9,7 +9,7 @@ import TcRnTypes rnLExpr :: LHsExpr RdrName
-> RnM (LHsExpr Name, FreeVars)
-rnStmts :: forall thing.
+rnStmts :: --forall thing.
HsStmtContext Name -> [LStmt RdrName]
-> RnM (thing, FreeVars)
-> RnM (([LStmt Name], thing), FreeVars)
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 3ab1c421a7..8c75caa993 100644 --- 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 - (_, dup_fields :: [[RdrName]]) = removeDups compare + dup_fields :: [[RdrName]] + (_, dup_fields) = removeDups compare (map (unLoc . hsRecFieldId) fields) -- duplicate field reporting function diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 7e9598cfcb..1cdbde62c4 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -50,8 +50,6 @@ import FastString ( FastString ) import Outputable import FastTypes -import GHC.Exts ( indexArray# ) - import Data.Array import Data.Array.Base (unsafeAt) diff --git a/compiler/stranal/StrictAnal.lhs b/compiler/stranal/StrictAnal.lhs index 0ae3269597..5b19aea0b4 100644 --- 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) -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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index bd3cb8cb4b..205197a1a5 100644 --- 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) -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 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 897cca3dfe..6003923c5c 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -45,10 +45,12 @@ module Binary lazyGet, lazyPut, +#ifdef __GLASGOW_HASKELL__ -- GHC only: ByteArray(..), getByteArray, putByteArray, +#endif UserData(..), getUserData, setUserData, newReadState, newWriteState, @@ -84,7 +86,7 @@ import GHC.Real ( Ratio(..) ) 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(..) ) @@ -92,7 +94,7 @@ import GHC.Handle ( openFileEx, IOModeEx(..) ) import System.IO ( openBinaryFile ) #endif -#if __GLASGOW_HASKELL__ < 601 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 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) -#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 @@ -477,6 +493,10 @@ instance Binary Integer where (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# diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs index d625a6e6c3..306413573f 100644 --- a/compiler/utils/BufWrite.hs +++ b/compiler/utils/BufWrite.hs @@ -23,6 +23,7 @@ module BufWrite ( #include "HsVersions.h" import FastString +import FastTypes import FastMutInt import Control.Monad ( when ) @@ -30,11 +31,6 @@ import Data.Char ( ord ) 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) @@ -94,18 +90,18 @@ bPutFS b@(BufHandle buf r hdl) fs@(FastString _ len _ fp _) = 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) - then hPutBuf hdl (Ptr a#) len - else bPutLitString b a# len# + then hPutBuf hdl a len + else bPutLitString b a len_ else do - copyBytes (buf `plusPtr` i) (Ptr a#) len + copyBytes (buf `plusPtr` i) a len writeFastMutInt r (i+len) bFlush :: BufHandle -> IO () diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index f80b33f870..939dc4956b 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -54,7 +54,7 @@ import Data.Maybe 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 ) diff --git a/compiler/utils/FastBool.lhs b/compiler/utils/FastBool.lhs index d7776e4259..ee9b40ff26 100644 --- a/compiler/utils/FastBool.lhs +++ b/compiler/utils/FastBool.lhs @@ -5,6 +5,7 @@ \begin{code} module FastBool ( + --fastBool could be called bBox; isFastTrue, bUnbox; but they're not FastBool, fastBool, isFastTrue, fastOr, fastAnd ) where @@ -12,25 +13,55 @@ module FastBool ( -- Import the beggars import GHC.Exts - ( Int(..), Int#, (+#), (-#), (*#), - quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#) - ) 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 -fastOr _ _ = panic# "FastTypes: fastOr" +fastOr _ _ = panicFastInt "FastTypes: fastOr" 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__ */ diff --git a/compiler/utils/FastFunctions.lhs b/compiler/utils/FastFunctions.lhs new file mode 100644 index 0000000000..5d8ff23dbd --- /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 ca7c2c71af..a22cae043c 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -33,7 +33,9 @@ module FastString mkFastStringBytes, mkFastStringByteList, mkFastStringForeignPtr, +#if defined(__GLASGOW_HASKELL__) mkFastString#, +#endif mkZFastString, mkZFastStringBytes, @@ -65,8 +67,15 @@ module FastString -- * LitStrings LitString, +#if defined(__GLASGOW_HASKELL__) mkLitString#, - strLength +#else + mkLitString, +#endif + unpackLitString, + strLength, + + ptrStrLength ) where -- This #define suppresses the "import FastString" that @@ -75,6 +84,8 @@ module FastString #include "HsVersions.h" import Encoding +import FastTypes +import FastFunctions 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.Char ( ord ) 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 -mkFastString# a# = mkFastStringBytes ptr (strLength ptr) +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) 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 - 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) - h2 = (c +# (h *# 128#)) `remInt#` hASH_TBL_SIZE# + h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` hASH_TBL_SIZE# -- ----------------------------------------------------------------------------- -- Operations @@ -446,8 +458,8 @@ tailFS (FastString _ n_bytes _ buf enc) = 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 "" @@ -475,23 +487,77 @@ hPutFS handle (FastString _ len _ fp _) -- ----------------------------------------------------------------------------- -- 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# +#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 --- 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. +-- We only use CChar here to be parallel to the imported +-- peekC(A)StringLen. pokeCAString :: Ptr CChar -> String -> IO () pokeCAString ptr str = let @@ -500,7 +566,7 @@ pokeCAString ptr str = in go str 0 -#if __GLASGOW_HASKELL__ <= 602 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 602 peekCAStringLen = peekCStringLen #endif \end{code} diff --git a/compiler/utils/FastTypes.lhs b/compiler/utils/FastTypes.lhs index bce98f479c..71a317b1c9 100644 --- a/compiler/utils/FastTypes.lhs +++ b/compiler/utils/FastTypes.lhs @@ -1,32 +1,106 @@ % % (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} + +--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, - (==#), (<#), (<=#), (>=#), (>#), + --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 +#define COMPILING_FAST_STRING +#include "HsVersions.h" + #if defined(__GLASGOW_HASKELL__) -- Import the beggars import GHC.Exts - ( Int(..), Int#, (+#), (-#), (*#), - quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#) - ) 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# +--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__ */ +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 @@ -35,27 +109,64 @@ iUnbox x = x (-#) = (-) (*#) = (*) quotFastInt = quot +--quotRemFastInt = quotRem 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. -(+#) :: 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__ */ +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 @@ -64,5 +175,19 @@ iUnbox :: Int -> 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} diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index d3a2c64797..b3dfb2783b 100644 --- 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 -#if __GLASGOW_HASKELL__ +#ifdef __GLASGOW_HASKELL__ {-# 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 839eda1493..ef856d0f54 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -45,9 +45,9 @@ module Outputable ( pprHsChar, pprHsString, -- error handling - pprPanic, assertPprPanic, pprPanic#, pprPgmError, + pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, warnPprTrace, - trace, pgmError, panic, panic#, assertPanic + trace, pgmError, panic, panicFastInt, assertPanic ) where #include "HsVersions.h" @@ -59,7 +59,6 @@ import {-# SOURCE #-} OccName( OccName ) import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString import FastTypes -import GHC.Ptr import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -336,7 +335,7 @@ empty :: 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 @@ -625,8 +624,8 @@ pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compi -- (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 diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 94f01d4c34..defbbef630 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -14,7 +14,7 @@ module Panic GhcException(..), showGhcException, ghcError, progName, pgmError, - panic, panic#, assertPanic, trace, + panic, panicFastInt, assertPanic, trace, 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 -#if __GLASGOW_HASKELL__ < 603 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 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) -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 = diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index 9c94c8eb0c..f1051b04af 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -186,14 +186,17 @@ module Pretty ( import BufWrite import FastString - -import GHC.Exts +import FastTypes 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(..) ) +#endif -- Don't import Util( assertPanic ) because it makes a loop in the module structure @@ -203,64 +206,11 @@ infixl 5 $$, $+$ \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} -#if defined(__GLASGOW_HASKELL__) - --- Glasgow Haskell - -- 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} @@ -321,7 +271,7 @@ punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, 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 @@ -491,8 +441,8 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout. 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 @@ -510,7 +460,7 @@ reduceDoc p = p 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' @@ -597,24 +547,27 @@ empty = Empty 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) #-} +#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 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 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 @@ -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 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 @@ -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 (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 - 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} -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! -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) @@ -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 p | g = textBeside_ space_text ILIT(1) p +nilBeside g p | g = textBeside_ space_text (_ILIT(1)) p | otherwise = p \end{code} @@ -730,24 +683,24 @@ sep = sepX True -- Separate with spaces 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) -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 (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 (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 @@ -784,20 +737,20 @@ fcat = fill False -- 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 (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 (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 @@ -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 - k1 | g = k MINUS ILIT(1) + k1 | g = k -# _ILIT(1) | 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! -best IBOX(w) IBOX(r) p - = get w p +best w_ r_ p + = get (iUnbox w_) p 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) - 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) - 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 - 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) -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 -fits :: INT -- Space available +fits :: FastInt -- 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 (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. @@ -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 - -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} @@ -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 = 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 - 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 - ZigZagMode | k GREQ gap_width + ZigZagMode | k >=# gap_width -> 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` ( - lay1 (k PLUS shift) s sl p ))) + lay1 (k +# shift) 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 (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 - 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 - lay ILIT(0) doc + lay (_ILIT(0)) doc }} 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} @@ -1032,9 +974,9 @@ printDoc mode hdl doc 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 diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs index 92a937b74f..0b0874a9fc 100644 --- a/compiler/utils/StringBuffer.lhs +++ b/compiler/utils/StringBuffer.lhs @@ -47,22 +47,22 @@ module StringBuffer 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 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 -#if __GLASGOW_HASKELL__ < 601 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601 openBinaryFile fp mode = openFileEx fp (BinaryMode mode) #endif @@ -216,28 +216,28 @@ lexemeToFastString (StringBuffer buf _ cur) len = -- ----------------------------------------------------------------------------- -- Parsing integer strings in various bases - +{- 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 -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 - | 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} diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 2184f52db6..59158f38b2 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -51,12 +51,10 @@ module UniqFM ( #include "HsVersions.h" -import Unique ( Uniquable(..), Unique, getKey#, mkUniqueGrimily ) +import Unique ( Uniquable(..), Unique, getKeyFastInt, mkUniqueGrimily ) import Maybes ( maybeToBool ) import FastTypes import Outputable - -import GHC.Exts -- Lots of Int# operations \end{code} %************************************************************************ @@ -237,8 +235,8 @@ First the ways of building a UniqFM. \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 @@ -257,13 +255,13 @@ could be optimised using it. \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 - = insert_ele combiner fm (getKey# (getUnique key)) elt + = insert_ele combiner fm (getKeyFastInt (getUnique key)) elt 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 @@ -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 - = 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 - = 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} @@ -285,10 +283,10 @@ Now ways of removing things from UniqFM. \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 @@ -539,9 +537,7 @@ mapUFM _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 @@ -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) -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 - = case lookUp fm (getKey# (getUnique key)) of + = case lookUp fm (getKeyFastInt (getUnique key)) of 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 -lookUp :: UniqFM a -> Int# -> Maybe a +lookUp :: UniqFM a -> FastInt -> Maybe a 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 - = 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 @@ -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 - 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_ - = NodeUFMData (((j `shiftL_` l) +# l) *# p) p + = NodeUFMData (((shiftL1 j) +# _ILIT(1)) *# p) p | 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 @@ -832,20 +824,14 @@ This might be better in Util.lhs ? 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} diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs index 9b61454236..08d35758a5 100644 --- 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} -#if __GLASGOW_HASKELL__ +#ifdef __GLASGOW_HASKELL__ {-# SPECIALIZE addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique #-} diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 852bb90289..01685f3326 100644 --- 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 - = elem (_ILIT 0) x ys + = elem (_ILIT(0)) x 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 - = notElem (_ILIT 0) x ys + = notElem (_ILIT(0)) x 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} @@ -353,7 +353,7 @@ isn'tIn msg x ys 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'" |