Commit 206b4dec authored by Isaac Dupree's avatar Isaac Dupree

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
parent 1286da96
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
......@@ -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}
%************************************************************************
......
......@@ -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}
%************************************************************************
......
......@@ -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 }
......
......@@ -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
......
/* 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
......@@ -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))
-- -----------------------------------------------------------------------------
......
......@@ -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
......
......@@ -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.