Commit 2f29ebbb authored by thomie's avatar thomie Committed by Ben Gamari

Refactor: delete most of the module FastTypes

This reverses some of the work done in #1405, and goes back to the
assumption that the bootstrap compiler understands GHC-haskell.

In particular:
  * use MagicHash instead of _ILIT and _CLIT
  * pattern matching on I# if possible, instead of using iUnbox
    unnecessarily
  * use Int#/Char#/Addr# instead of the following type synonyms:
    - type FastInt   = Int#
    - type FastChar  = Char#
    - type FastPtr a = Addr#
  * inline the following functions:
    - iBox           = I#
    - cBox           = C#
    - fastChr        = chr#
    - fastOrd        = ord#
    - eqFastChar     = eqChar#
    - shiftLFastInt  = uncheckedIShiftL#
    - shiftR_FastInt = uncheckedIShiftRL#
    - shiftRLFastInt = uncheckedIShiftRL#
  * delete the following unused functions:
    - minFastInt
    - maxFastInt
    - uncheckedIShiftRA#
    - castFastPtr
    - panicDocFastInt and pprPanicFastInt
  * rename panicFastInt back to panic#

These functions remain, since they actually do something:
  * iUnbox
  * bitAndFastInt
  * bitOrFastInt

Test Plan: validate

Reviewers: austin, bgamari

Subscribers: rwbarton

Differential Revision: https://phabricator.haskell.org/D1141

GHC Trac Issues: #1405
parent 3452473b
......@@ -48,7 +48,6 @@ import PrelNames
import Type
import TyCon
import Outputable
import FastTypes
import FastString
import BasicTypes
import Binary
......@@ -422,21 +421,21 @@ cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
litTag :: Literal -> FastInt
litTag (MachChar _) = _ILIT(1)
litTag (MachStr _) = _ILIT(2)
litTag (MachNullAddr) = _ILIT(3)
litTag (MachInt _) = _ILIT(4)
litTag (MachWord _) = _ILIT(5)
litTag (MachInt64 _) = _ILIT(6)
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
litTag (MachLabel _ _ _) = _ILIT(10)
litTag (LitInteger {}) = _ILIT(11)
cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT
| otherwise = GT
litTag :: Literal -> Int
litTag (MachChar _) = 1
litTag (MachStr _) = 2
litTag (MachNullAddr) = 3
litTag (MachInt _) = 4
litTag (MachWord _) = 5
litTag (MachInt64 _) = 6
litTag (MachWord64 _) = 7
litTag (MachFloat _) = 8
litTag (MachDouble _) = 9
litTag (MachLabel _ _ _) = 10
litTag (LitInteger {}) = 11
{-
Printing
......@@ -535,4 +534,4 @@ hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
-- since we use * to combine hash values
hashFS :: FastString -> Int
hashFS s = iBox (uniqueOfFS s)
hashFS s = uniqueOfFS s
......@@ -86,7 +86,6 @@ import Util
import Maybes
import Binary
import DynFlags
import FastTypes
import FastString
import Outputable
......@@ -105,8 +104,7 @@ import Data.Data
data Name = Name {
n_sort :: NameSort, -- What sort of name it is
n_occ :: !OccName, -- Its occurrence name
n_uniq :: FastInt, -- UNPACK doesn't work, recursive type
--(note later when changing Int# -> FastInt: is that still true about UNPACK?)
n_uniq :: {-# UNPACK #-} !Int,
n_loc :: !SrcSpan -- Definition site
}
deriving Typeable
......@@ -184,7 +182,7 @@ nameModule :: Name -> Module
nameSrcLoc :: Name -> SrcLoc
nameSrcSpan :: Name -> SrcSpan
nameUnique name = mkUniqueGrimily (iBox (n_uniq name))
nameUnique name = mkUniqueGrimily (n_uniq name)
nameOccName name = n_occ name
nameSrcLoc name = srcSpanStart (n_loc name)
nameSrcSpan name = n_loc name
......@@ -309,7 +307,7 @@ isSystemName _ = False
-- | Create a name which is (for now at least) local to the current module and hence
-- does not need a 'Module' to disambiguate it from other 'Name's
mkInternalName :: Unique -> OccName -> SrcSpan -> Name
mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq
mkInternalName uniq occ loc = Name { n_uniq = getKey uniq
, n_sort = Internal
, n_occ = occ
, n_loc = loc }
......@@ -324,12 +322,12 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq
mkClonedInternalName :: Unique -> Name -> Name
mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
= Name { n_uniq = getKey uniq, n_sort = Internal
, n_occ = occ, n_loc = loc }
mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
= Name { n_uniq = getKey uniq, n_sort = Internal
, n_occ = derive_occ occ, n_loc = loc }
-- | Create a name which definitely originates in the given module
......@@ -338,13 +336,13 @@ mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
-- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName
-- with some fresh unique without populating the Name Cache
mkExternalName uniq mod occ loc
= Name { n_uniq = getKeyFastInt uniq, n_sort = External mod,
= Name { n_uniq = getKey uniq, n_sort = External mod,
n_occ = occ, n_loc = loc }
-- | Create a name which is actually defined by the compiler itself
mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name
mkWiredInName mod occ uniq thing built_in
= Name { n_uniq = getKeyFastInt uniq,
= Name { n_uniq = getKey uniq,
n_sort = WiredIn mod thing built_in,
n_occ = occ, n_loc = wiredInSrcSpan }
......@@ -353,7 +351,7 @@ mkSystemName :: Unique -> OccName -> Name
mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan
mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = System
mkSystemNameAt uniq occ loc = Name { n_uniq = getKey uniq, n_sort = System
, n_occ = occ, n_loc = loc }
mkSystemVarName :: Unique -> FastString -> Name
......@@ -371,7 +369,7 @@ mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan
-- 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 = getKeyFastInt uniq}
setNameUnique name uniq = name {n_uniq = getKey uniq}
-- This is used for hsigs: we want to use the name of the originally exported
-- entity, but edit the location to refer to the reexport site
......@@ -410,7 +408,7 @@ mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
-}
cmpName :: Name -> Name -> Ordering
cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2)
cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2
stableNameCmp :: Name -> Name -> Ordering
-- Compare lexicographically
......@@ -505,7 +503,7 @@ pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})
External mod -> pprExternal sty uniq mod occ False UserSyntax
System -> pprSystem sty uniq occ
Internal -> pprInternal sty uniq occ
where uniq = mkUniqueGrimily (iBox u)
where uniq = mkUniqueGrimily u
pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
pprExternal sty uniq mod occ is_wired is_builtin
......
......@@ -25,12 +25,13 @@ module UniqSupply (
) where
import Unique
import FastTypes
import GHC.IO
import MonadUtils
import Control.Monad
import Data.Bits
import Data.Char
{-
************************************************************************
......@@ -45,7 +46,7 @@ import Control.Monad
-- also manufacture an arbitrary number of further 'UniqueSupply' values,
-- which will be distinct from the first and from all others.
data UniqSupply
= MkSplitUniqSupply FastInt -- make the Unique with this
= MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this
UniqSupply UniqSupply
-- when split => these two supplies
......@@ -67,7 +68,7 @@ takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply)
-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply
mkSplitUniqSupply c
= case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of
= case ord c `shiftL` 24 of
mask -> let
-- here comes THE MAGIC:
......@@ -75,11 +76,11 @@ mkSplitUniqSupply c
mk_supply
-- NB: Use unsafeInterleaveIO for thread-safety.
= unsafeInterleaveIO (
genSym >>= \ u_ -> case iUnbox u_ of { u -> (
genSym >>= \ u ->
mk_supply >>= \ s1 ->
mk_supply >>= \ s2 ->
return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2)
)})
return (MkSplitUniqSupply (mask .|. u) s1 s2)
)
in
mk_supply
......@@ -88,9 +89,9 @@ foreign import ccall unsafe "genSym" genSym :: IO Int
splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2
uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n)
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1)
uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1)
{-
************************************************************************
......
......@@ -28,7 +28,7 @@ module Unique (
pprUnique,
mkUniqueGrimily, -- Used in UniqSupply only!
getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only!
getKey, -- Used in Var, UniqFM, Name only!
mkUnique, unpkUnique, -- Used in BinIface only
incrUnique, -- Used for renumbering
......@@ -61,16 +61,15 @@ module Unique (
#include "HsVersions.h"
import BasicTypes
import FastTypes
import FastString
import Outputable
-- import StaticFlags
import Util
--just for implementing a fast [0,61) -> Char function
import GHC.Exts (indexCharOffAddr#, Char(..))
-- just for implementing a fast [0,61) -> Char function
import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))
import Data.Char ( chr, ord )
import Data.Bits
{-
************************************************************************
......@@ -88,7 +87,7 @@ Fast comparison is everything on @Uniques@:
-- | The type of unique identifiers that are used in many places in GHC
-- for fast ordering and equality tests. You should generate these with
-- the functions from the 'UniqSupply' module
data Unique = MkUnique FastInt
data Unique = MkUnique {-# UNPACK #-} !Int
{-
Now come the functions which construct uniques from their pieces, and vice versa.
......@@ -99,24 +98,21 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
getKeyFastInt :: Unique -> FastInt -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily x = MkUnique (iUnbox x)
mkUniqueGrimily = MkUnique
{-# INLINE getKey #-}
getKey (MkUnique x) = iBox x
{-# INLINE getKeyFastInt #-}
getKeyFastInt (MkUnique x) = x
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i +# _ILIT(1))
incrUnique (MkUnique i) = MkUnique (i + 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' (iBox i + delta)
deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
-- newTagUnique changes the "domain" of a unique to a different char
newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
......@@ -131,17 +127,17 @@ mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
-- NOT EXPORTED, so that we can see all the Chars that
-- are used in this one module
mkUnique c i
= MkUnique (tag `bitOrFastInt` bits)
= MkUnique (tag .|. bits)
where
!tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24)
!bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-}
tag = ord c `shiftL` 24
bits = i .&. 16777215 {-``0x00ffffff''-}
unpkUnique (MkUnique u)
= let
-- 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''-})
tag = chr (u `shiftR` 24)
i = u .&. 16777215 {-``0x00ffffff''-}
in
(tag, i)
......@@ -161,7 +157,7 @@ hasKey :: Uniquable a => a -> Unique -> Bool
x `hasKey` k = getUnique x == k
instance Uniquable FastString where
getUnique fs = mkUniqueGrimily (iBox (uniqueOfFS fs))
getUnique fs = mkUniqueGrimily (uniqueOfFS fs)
instance Uniquable Int where
getUnique i = mkUniqueGrimily i
......@@ -179,13 +175,13 @@ use `deriving' because we want {\em precise} control of ordering
-}
eqUnique, ltUnique, leUnique :: Unique -> Unique -> Bool
eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2
ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2
leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2
eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2
ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2
leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2
cmpUnique :: Unique -> Unique -> Ordering
cmpUnique (MkUnique u1) (MkUnique u2)
= if u1 ==# u2 then EQ else if u1 <# u2 then LT else GT
= if u1 == u2 then EQ else if u1 < u2 then LT else GT
instance Eq Unique where
a == b = eqUnique a b
......@@ -239,20 +235,18 @@ Code stolen from Lennart.
iToBase62 :: Int -> String
iToBase62 n_
= ASSERT(n_ >= 0) go (iUnbox n_) ""
= ASSERT(n_ >= 0) go n_ ""
where
go n cs | n <# _ILIT(62)
= case chooseChar62 n of { c -> c `seq` (c : cs) }
| otherwise
= 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
go n cs | n < 62
= let !c = chooseChar62 n in c : cs
| otherwise
= go q (c : cs) where (q, r) = quotRem n 62
!c = chooseChar62 r
chooseChar62 :: Int -> Char
{-# INLINE chooseChar62 #-}
chooseChar62 n = C# (indexCharOffAddr# chars62 n)
!chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)
chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
{-
************************************************************************
......@@ -345,7 +339,7 @@ mkCostCentreUnique = mkUnique 'C'
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique
-- See Note [The Unique of an OccName] in OccName
mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs))
mkDataOccUnique fs = mkUnique 'd' (iBox (uniqueOfFS fs))
mkTvOccUnique fs = mkUnique 'v' (iBox (uniqueOfFS fs))
mkTcOccUnique fs = mkUnique 'c' (iBox (uniqueOfFS fs))
mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs)
mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)
mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs)
mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs)
......@@ -75,7 +75,6 @@ import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo,
import Name hiding (varName)
import Unique
import Util
import FastTypes
import FastString
import Outputable
......@@ -154,7 +153,8 @@ data Var
= TyVar { -- Type and kind variables
-- see Note [Kind and type variables]
varName :: !Name,
realUnique :: FastInt, -- Key for fast comparison
realUnique :: {-# UNPACK #-} !Int,
-- ^ Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
varType :: Kind -- ^ The type or kind of the 'Var' in question
......@@ -164,13 +164,13 @@ data Var
-- Used for kind variables during
-- inference, as well
varName :: !Name,
realUnique :: FastInt,
realUnique :: {-# UNPACK #-} !Int,
varType :: Kind,
tc_tv_details :: TcTyVarDetails }
| Id {
varName :: !Name,
realUnique :: FastInt,
realUnique :: {-# UNPACK #-} !Int,
varType :: Type,
idScope :: IdScope,
id_details :: IdDetails, -- Stable, doesn't change
......@@ -228,13 +228,13 @@ instance Uniquable Var where
getUnique = varUnique
instance Eq Var where
a == b = realUnique a ==# realUnique b
a == b = realUnique a == realUnique b
instance Ord Var where
a <= b = realUnique a <=# realUnique b
a < b = realUnique a <# realUnique b
a >= b = realUnique a >=# realUnique b
a > b = realUnique a ># realUnique b
a <= b = realUnique a <= realUnique b
a < b = realUnique a < realUnique b
a >= b = realUnique a >= realUnique b
a > b = realUnique a > realUnique b
a `compare` b = varUnique a `compare` varUnique b
instance Data Var where
......@@ -244,16 +244,16 @@ instance Data Var where
dataTypeOf _ = mkNoRepType "Var"
varUnique :: Var -> Unique
varUnique var = mkUniqueGrimily (iBox (realUnique var))
varUnique var = mkUniqueGrimily (realUnique var)
setVarUnique :: Var -> Unique -> Var
setVarUnique var uniq
= var { realUnique = getKeyFastInt uniq,
= var { realUnique = getKey uniq,
varName = setNameUnique (varName var) uniq }
setVarName :: Var -> Name -> Var
setVarName var new_name
= var { realUnique = getKeyFastInt (getUnique new_name),
= var { realUnique = getKey (getUnique new_name),
varName = new_name }
setVarType :: Id -> Type -> Id
......@@ -292,7 +292,7 @@ updateTyVarKindM update tv
mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = TyVar { varName = name
, realUnique = getKeyFastInt (nameUnique name)
, realUnique = getKey (nameUnique name)
, varType = kind
}
......@@ -300,7 +300,7 @@ mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar name kind details
= -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar'
TcTyVar { varName = name,
realUnique = getKeyFastInt (nameUnique name),
realUnique = getKey (nameUnique name),
varType = kind,
tc_tv_details = details
}
......@@ -317,7 +317,7 @@ mkKindVar :: Name -> SuperKind -> KindVar
-- to superKind here.
mkKindVar name kind = TyVar
{ varName = name
, realUnique = getKeyFastInt (nameUnique name)
, realUnique = getKey (nameUnique name)
, varType = kind }
{-
......@@ -358,7 +358,7 @@ mkExportedLocalVar details name ty info
mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id
mk_id name ty scope details info
= Id { varName = name,
realUnique = getKeyFastInt (nameUnique name),
realUnique = getKey (nameUnique name),
varType = ty,
idScope = scope,
id_details = details,
......
......@@ -56,7 +56,6 @@ import Unique
import Util
import Maybes
import Outputable
import FastTypes
import StaticFlags
import FastString
......@@ -69,7 +68,7 @@ import FastString
-}
-- | A set of variables that are in scope at some point
data InScopeSet = InScope (VarEnv Var) FastInt
data InScopeSet = InScope (VarEnv Var) {-# UNPACK #-} !Int
-- The (VarEnv Var) is just a VarSet. But we write it like
-- this to remind ourselves that you can look up a Var in
-- the InScopeSet. Typically the InScopeSet contains the
......@@ -81,7 +80,7 @@ data InScopeSet = InScope (VarEnv Var) FastInt
-- the case in the past, when we had a grevious hack
-- mapping var1 to var2.
--
-- The FastInt is a kind of hash-value used by uniqAway
-- The Int is a kind of hash-value used by uniqAway
-- For example, it might be the size of the set
-- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
......@@ -89,25 +88,25 @@ instance Outputable InScopeSet where
ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s
emptyInScopeSet :: InScopeSet
emptyInScopeSet = InScope emptyVarSet (_ILIT(1))
emptyInScopeSet = InScope emptyVarSet 1
getInScopeVars :: InScopeSet -> VarEnv Var
getInScopeVars (InScope vs _) = vs
mkInScopeSet :: VarEnv Var -> InScopeSet
mkInScopeSet in_scope = InScope in_scope (_ILIT(1))
mkInScopeSet in_scope = InScope in_scope 1
extendInScopeSet :: InScopeSet -> Var -> InScopeSet
extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1))
extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n + 1)
extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
extendInScopeSetList (InScope in_scope n) vs
= InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
(n +# iUnbox (length vs))
(n + length vs)
extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
extendInScopeSetSet (InScope in_scope n) vs
= InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs))
= InScope (in_scope `plusVarEnv` vs) (n + sizeUFM vs)
delInScopeSet :: InScopeSet -> Var -> InScopeSet
delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
......@@ -141,19 +140,19 @@ uniqAway in_scope var
uniqAway' :: InScopeSet -> Var -> Var
-- This one *always* makes up a new variable
uniqAway' (InScope set n) var
= try (_ILIT(1))
= try 1
where
orig_unique = getUnique var
try k
| debugIsOn && (k ># _ILIT(1000))
= pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
| uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
| debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(3))
= pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
| debugIsOn && (k > 1000)
= pprPanic "uniqAway loop:" (ppr k <+> text "tries" <+> ppr var <+> int n)
| uniq `elemVarSetByKey` set = try (k + 1)
| debugIsOn && opt_PprStyle_Debug && (k > 3)
= pprTrace "uniqAway:" (ppr k <+> text "tries" <+> ppr var <+> int n)
setVarUnique var uniq
| otherwise = setVarUnique var uniq
where
uniq = deriveUnique orig_unique (iBox (n *# k))
uniq = deriveUnique orig_unique (n * k)
{-
************************************************************************
......
......@@ -21,7 +21,6 @@ import CmmUtils
import Cmm
import DynFlags
import FastTypes
import Outputable
import Platform
......@@ -376,30 +375,19 @@ cmmMachOpFoldM _ _ _ = Nothing
-- This algorithm for determining the $\log_2$ of exact powers of 2 comes
-- from GCC. It requires bit manipulation primitives, and we use GHC
-- extensions. Tough.
--
-- Used to be in MachInstrs --SDM.
-- ToDo: remove use of unboxery --SDM.
-- 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 iUnbox (fromInteger x_) of { x ->
if (x `bitAndFastInt` negateFastInt x) /=# x then
if (x .&. (-x)) /= x then
Nothing
else
Just (toInteger (iBox (pow2 x)))
}
Just (pow2 x)
where
pow2 x | x ==# _ILIT(1) = _ILIT(0)
| otherwise = _ILIT(1) +# pow2 (x `shiftR_FastInt` _ILIT(1))
pow2 x | x == 1 = 0
| otherwise = 1 + pow2 (x `shiftR` 1)
-- -----------------------------------------------------------------------------
-- Utils
......
......@@ -59,7 +59,6 @@ import PrelNames
import TysPrim ( realWorldStatePrimTy )
import Bag
import Util
import FastTypes
import FastString
import Outputable
import ForeignCall
......@@ -332,17 +331,17 @@ calcUnfoldingGuidance dflags (Tick t expr)
| not (tickishIsCode t) -- non-code ticks don't matter for unfolding
= calcUnfoldingGuidance dflags expr
calcUnfoldingGuidance dflags expr
= case sizeExpr dflags (iUnbox bOMB_OUT_SIZE) val_bndrs body of
= case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of
TooBig -> UnfNever
SizeIs size cased_bndrs scrut_discount
| uncondInline expr n_val_bndrs (iBox size)
| uncondInline expr n_val_bndrs size
-> UnfWhen { ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtOk
, ug_arity = n_val_bndrs } -- Note [INLINE for small functions]
| otherwise
-> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs
, ug_size = iBox size
, ug_res = iBox scrut_discount }
, ug_size = size
, ug_res = scrut_discount }
where
(bndrs, body) = collectBinders expr
......@@ -469,7 +468,7 @@ uncondInline rhs arity size
| otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4)
sizeExpr :: DynFlags
-> FastInt -- Bomb out if it gets bigger than this
-> Int -- Bomb out if it gets bigger than this
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
-> CoreExpr
......@@ -525,7 +524,7 @@ sizeExpr dflags 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 _ _) -- Size of biggest alternative
= SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut
= SizeIs tot (unitBag (v, 20 + tot - max) `unionBags` tot_disc) tot_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of the largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
......@@ -605,22 +604,22 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
-- These addSize things have to be here because
-- I don't want to give them bOMB_OUT_SIZE as an argument
addSizeN TooBig _ = TooBig
addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d
-- addAltSize is used to add the sizes of case alternatives
addAltSize TooBig _ = TooBig
addAltSize _ TooBig = TooBig
addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
= mkSizeIs bOMB_OUT_SIZE (n1 +# n2)
= mkSizeIs bOMB_OUT_SIZE (n1 + n2)
(xs `unionBags` ys)
(d1 +# d2) -- Note [addAltSize result discounts]
(d1 + d2) -- Note [addAltSize result discounts]
-- This variant ignores the result discount from its LEFT argument
-- It's used when the second argument isn't part of the result
addSizeNSD TooBig _ = TooBig
addSizeNSD _ TooBig = TooBig
addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
= mkSizeIs bOMB_OUT_SIZE (n1 +# n2)
= mkSizeIs bOMB_OUT_SIZE (n1 + n2)
(xs `unionBags` ys)
d2 -- Ignore d1
......@@ -648,7 +647,7 @@ classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize
classOpSize _ _ []
= sizeZero
classOpSize dflags top_args (arg1 : other_args)
= SizeIs (iUnbox size) arg_discount (_ILIT(0))
= SizeIs size arg_discount 0
where
size = 20 + (10 * length other_args)
-- If the class op is scrutinising a lambda bound dictionary then
......@@ -665,7 +664,7 @@ funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
funSize dflags top_args fun n_val_args voids
| fun `hasKey` buildIdKey = buildSize
| fun `hasKey` augmentIdKey = augmentSize
| otherwise = SizeIs (iUnbox size) arg_discount (iUnbox res_discount)