diff options
author | Thomas Miedema <thomasmiedema@gmail.com> | 2015-08-21 10:44:54 +0200 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-08-21 15:44:21 +0200 |
commit | 2f29ebbb6f8c914f2bba624f3edcc259274df8af (patch) | |
tree | c523018ed23dd32e45697fe177d6df5ad4b59b50 | |
parent | 3452473b4bb180ba327520067b8c6f2a8d6c4f4b (diff) | |
download | haskell-2f29ebbb6f8c914f2bba624f3edcc259274df8af.tar.gz |
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
27 files changed, 268 insertions, 537 deletions
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index ced05a4d2f..5f3b75dafa 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -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 diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 506b60fb95..79f14ab93c 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -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 diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs index 3d0573dba0..67248db72d 100644 --- a/compiler/basicTypes/UniqSupply.hs +++ b/compiler/basicTypes/UniqSupply.hs @@ -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) {- ************************************************************************ diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index 70600d8d11..5ce9c64a0c 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -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) diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index 9827450bb8..7c4ccfcdc3 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -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, diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 1d1c0604a3..424edcafe7 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -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) {- ************************************************************************ diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 84499b97de..7c634c2201 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -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 diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 91dbed9ecb..b04c13d886 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -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) + | otherwise = SizeIs size arg_discount res_discount where some_val_args = n_val_args > 0 @@ -689,13 +688,13 @@ funSize dflags top_args fun n_val_args voids conSize :: DataCon -> Int -> ExprSize conSize dc n_val_args - | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables + | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables -- See Note [Unboxed tuple size and result discount] - | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args))) + | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args)) -- See Note [Constructor size and result discount] - | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args))) + | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args)) {- Note [Constructor size and result discount] @@ -780,7 +779,7 @@ primOpSize op n_val_args buildSize :: ExprSize -buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) +buildSize = SizeIs 0 emptyBag 40 -- 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 @@ -789,13 +788,13 @@ buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) -- The "4" is rather arbitrary. augmentSize :: ExprSize -augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) +augmentSize = SizeIs 0 emptyBag 40 -- Ditto (augment t (\cn -> e) ys) should cost only the cost of -- e plus ys. The -2 accounts for the \cn -- When we return a lambda, give a discount if it's used (applied) lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize -lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (iUnbox (ufFunAppDiscount dflags)) +lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) lamScrutDiscount _ TooBig = TooBig {- @@ -853,36 +852,41 @@ In a function application (f a b) Code for manipulating sizes -} -data ExprSize = TooBig - | SizeIs FastInt -- Size found - !(Bag (Id,Int)) -- Arguments cased herein, and discount for each such - FastInt -- Size to subtract if result is scrutinised - -- by a case expression +-- | The size of an candidate expression for unfolding +data ExprSize + = TooBig + | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found + , _es_args :: !(Bag (Id,Int)) + -- ^ Arguments cased herein, and discount for each such + , _es_discount :: {-# UNPACK #-} !Int + -- ^ Size to subtract if result is scrutinised by a case + -- expression + } instance Outputable ExprSize where ppr TooBig = ptext (sLit "TooBig") - ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox c)) + ppr (SizeIs a _ c) = brackets (int a <+> int c) -- subtract the discount before deciding whether to bale out. eg. we -- want to inline a large constructor application into a selector: -- tup = (a_1, ..., a_99) -- x = case tup of ... -- -mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize -mkSizeIs max n xs d | (n -# d) ># max = TooBig - | otherwise = SizeIs n xs d +mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize +mkSizeIs max n xs d | (n - d) > max = TooBig + | otherwise = SizeIs n xs d maxSize :: ExprSize -> ExprSize -> ExprSize maxSize TooBig _ = TooBig maxSize _ TooBig = TooBig -maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2 = s1 +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 | otherwise = s2 sizeZero :: ExprSize sizeN :: Int -> ExprSize -sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) -sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) +sizeZero = SizeIs 0 emptyBag 0 +sizeN n = SizeIs n emptyBag 0 {- ************************************************************************ @@ -899,7 +903,7 @@ actual arguments. couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool couldBeSmallEnoughToInline dflags threshold rhs - = case sizeExpr dflags (iUnbox threshold) [] body of + = case sizeExpr dflags threshold [] body of TooBig -> False _ -> True where diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 4361c8e244..c8a3893d0f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -444,7 +444,6 @@ Library FastFunctions FastMutInt FastString - FastTypes Fingerprint FiniteMap GraphBase diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 817ab8b9c1..69ab85d5da 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -507,7 +507,6 @@ compiler_stage2_dll0_MODULES = \ FastFunctions \ FastMutInt \ FastString \ - FastTypes \ Fingerprint \ FiniteMap \ ForeignCall \ diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 8fbe257b83..8b8b9df255 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -654,7 +654,6 @@ ppr_expr (ExplicitTuple exprs boxity) punc (Missing {} : _) = comma punc [] = empty ---avoid using PatternSignatures for stage1 code portability ppr_expr (HsLam matches) = pprMatches (LambdaExpr :: HsMatchContext id) matches @@ -986,7 +985,6 @@ ppr_cmd (HsCmdApp c e) collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) ---avoid using PatternSignatures for stage1 code portability ppr_cmd (HsCmdLam matches) = pprMatches (LambdaExpr :: HsMatchContext id) matches diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs index 2b7746c6ce..2326ebdf6c 100644 --- a/compiler/main/GhcPlugins.hs +++ b/compiler/main/GhcPlugins.hs @@ -19,7 +19,7 @@ module GhcPlugins( module VarSet, module VarEnv, module NameSet, module NameEnv, module UniqSet, module UniqFM, module FiniteMap, module Util, module Serialized, module SrcLoc, module Outputable, - module UniqSupply, module Unique, module FastString, module FastTypes + module UniqSupply, module Unique, module FastString ) where -- Plugin stuff itself @@ -81,4 +81,3 @@ import Outputable import UniqSupply import Unique ( Unique, Uniquable(..) ) import FastString -import FastTypes diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index d0eb183ea7..05efaeb1f4 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -60,7 +60,6 @@ import Unique import CodeGen.Platform import DynFlags import Outputable -import FastTypes import Platform import Data.Word ( Word8, Word16, Word32, Word64 ) @@ -75,44 +74,44 @@ import Data.Int ( Int8, Int16, Int32, Int64 ) -- as a neighbour. -- {-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt +virtualRegSqueeze :: RegClass -> VirtualReg -> Int virtualRegSqueeze cls vr = case cls of RcInteger -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) - _other -> _ILIT(0) + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 RcDouble -> case vr of - VirtualRegD{} -> _ILIT(1) - VirtualRegF{} -> _ILIT(0) - _other -> _ILIT(0) + VirtualRegD{} -> 1 + VirtualRegF{} -> 0 + _other -> 0 - _other -> _ILIT(0) + _other -> 0 {-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> FastInt +realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr = case cls of RcInteger -> case rr of RealRegSingle regNo - | regNo < 32 -> _ILIT(1) -- first fp reg is 32 - | otherwise -> _ILIT(0) + | regNo < 32 -> 1 -- first fp reg is 32 + | otherwise -> 0 - RealRegPair{} -> _ILIT(0) + RealRegPair{} -> 0 RcDouble -> case rr of RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) + | regNo < 32 -> 0 + | otherwise -> 1 - RealRegPair{} -> _ILIT(0) + RealRegPair{} -> 0 - _other -> _ILIT(0) + _other -> 0 mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index b42fb4c39e..be9248f9b6 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP #-} +{-# LANGUAGE CPP #-} module RegAlloc.Graph.TrivColorable ( trivColorable, @@ -14,11 +14,9 @@ import Reg import GraphBase import UniqFM -import FastTypes import Platform import Panic - -- trivColorable --------------------------------------------------------------- -- trivColorable function for the graph coloring allocator @@ -55,16 +53,16 @@ import Panic -- different regSqueeze function for each. -- accSqueeze - :: FastInt - -> FastInt - -> (reg -> FastInt) + :: Int + -> Int + -> (reg -> Int) -> UniqFM reg - -> FastInt + -> Int accSqueeze count maxCount squeeze ufm = acc count (eltsUFM ufm) where acc count [] = count - acc count _ | count >=# maxCount = count - acc count (r:rs) = acc (count +# squeeze r) rs + acc count _ | count >= maxCount = count + acc count (r:rs) = acc (count + squeeze r) rs {- Note [accSqueeze] ~~~~~~~~~~~~~~~~~~~~ @@ -100,13 +98,13 @@ the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows. trivColorable :: Platform - -> (RegClass -> VirtualReg -> FastInt) - -> (RegClass -> RealReg -> FastInt) + -> (RegClass -> VirtualReg -> Int) + -> (RegClass -> RealReg -> Int) -> Triv VirtualReg RegClass RealReg trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions - | let !cALLOCATABLE_REGS_INTEGER - = iUnbox (case platformArch platform of + | let cALLOCATABLE_REGS_INTEGER + = (case platformArch platform of ArchX86 -> 3 ArchX86_64 -> 5 ArchPPC -> 16 @@ -119,7 +117,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl ArchMipsel -> panic "trivColorable ArchMipsel" ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER (virtualRegSqueeze RcInteger) conflicts @@ -127,11 +125,11 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl (realRegSqueeze RcInteger) exclusions - = count3 <# cALLOCATABLE_REGS_INTEGER + = count3 < cALLOCATABLE_REGS_INTEGER trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions - | let !cALLOCATABLE_REGS_FLOAT - = iUnbox (case platformArch platform of + | let cALLOCATABLE_REGS_FLOAT + = (case platformArch platform of ArchX86 -> 0 ArchX86_64 -> 0 ArchPPC -> 0 @@ -144,7 +142,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus ArchMipsel -> panic "trivColorable ArchMipsel" ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT (virtualRegSqueeze RcFloat) conflicts @@ -152,11 +150,11 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus (realRegSqueeze RcFloat) exclusions - = count3 <# cALLOCATABLE_REGS_FLOAT + = count3 < cALLOCATABLE_REGS_FLOAT trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions - | let !cALLOCATABLE_REGS_DOUBLE - = iUnbox (case platformArch platform of + | let cALLOCATABLE_REGS_DOUBLE + = (case platformArch platform of ArchX86 -> 6 ArchX86_64 -> 0 ArchPPC -> 26 @@ -169,7 +167,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu ArchMipsel -> panic "trivColorable ArchMipsel" ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE (virtualRegSqueeze RcDouble) conflicts @@ -177,11 +175,11 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu (realRegSqueeze RcDouble) exclusions - = count3 <# cALLOCATABLE_REGS_DOUBLE + = count3 < cALLOCATABLE_REGS_DOUBLE trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions - | let !cALLOCATABLE_REGS_SSE - = iUnbox (case platformArch platform of + | let cALLOCATABLE_REGS_SSE + = (case platformArch platform of ArchX86 -> 8 ArchX86_64 -> 10 ArchPPC -> 0 @@ -194,7 +192,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex ArchMipsel -> panic "trivColorable ArchMipsel" ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchUnknown -> panic "trivColorable ArchUnknown") - , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE + , count2 <- accSqueeze 0 cALLOCATABLE_REGS_SSE (virtualRegSqueeze RcDoubleSSE) conflicts @@ -202,7 +200,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex (realRegSqueeze RcDoubleSSE) exclusions - = count3 <# cALLOCATABLE_REGS_SSE + = count3 < cALLOCATABLE_REGS_SSE -- Specification Code ---------------------------------------------------------- diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 4ae114b0ef..14a5192c2d 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -39,7 +39,6 @@ import Format import Unique import Outputable -import FastTypes {- The SPARC has 64 registers of interest; 32 integer registers and 32 @@ -81,60 +80,60 @@ classOfRealReg reg -- as a neighbour. -- {-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt +virtualRegSqueeze :: RegClass -> VirtualReg -> Int virtualRegSqueeze cls vr = case cls of RcInteger -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) - _other -> _ILIT(0) + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 RcFloat -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(2) - _other -> _ILIT(0) + VirtualRegF{} -> 1 + VirtualRegD{} -> 2 + _other -> 0 RcDouble -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(1) - _other -> _ILIT(0) + VirtualRegF{} -> 1 + VirtualRegD{} -> 1 + _other -> 0 - _other -> _ILIT(0) + _other -> 0 {-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> FastInt +realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr = case cls of RcInteger -> case rr of RealRegSingle regNo - | regNo < 32 -> _ILIT(1) - | otherwise -> _ILIT(0) + | regNo < 32 -> 1 + | otherwise -> 0 - RealRegPair{} -> _ILIT(0) + RealRegPair{} -> 0 RcFloat -> case rr of RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) + | regNo < 32 -> 0 + | otherwise -> 1 - RealRegPair{} -> _ILIT(2) + RealRegPair{} -> 2 RcDouble -> case rr of RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) + | regNo < 32 -> 0 + | otherwise -> 1 - RealRegPair{} -> _ILIT(1) + RealRegPair{} -> 1 - _other -> _ILIT(0) + _other -> 0 -- | All the allocatable registers in the machine, -- including register pairs. diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index 606e6f5d9e..9bd470b0d6 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -27,7 +27,6 @@ import Format import Outputable import Unique -import FastTypes import Platform import qualified X86.Regs as X86 @@ -37,7 +36,7 @@ import qualified PPC.Regs as PPC import qualified SPARC.Regs as SPARC -targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int targetVirtualRegSqueeze platform = case platformArch platform of ArchX86 -> X86.virtualRegSqueeze @@ -54,7 +53,7 @@ targetVirtualRegSqueeze platform ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" -targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int targetRealRegSqueeze platform = case platformArch platform of ArchX86 -> X86.realRegSqueeze diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 5c484743ca..4cb82ea224 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -57,8 +57,6 @@ import CLabel ( CLabel ) import DynFlags import Outputable import Platform -import FastTypes - -- | regSqueeze_class reg -- Calculuate the maximum number of register colors that could be @@ -66,55 +64,55 @@ import FastTypes -- as a neighbour. -- {-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt +virtualRegSqueeze :: RegClass -> VirtualReg -> Int virtualRegSqueeze cls vr = case cls of RcInteger -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) - _other -> _ILIT(0) + VirtualRegI{} -> 1 + VirtualRegHi{} -> 1 + _other -> 0 RcDouble -> case vr of - VirtualRegD{} -> _ILIT(1) - VirtualRegF{} -> _ILIT(0) - _other -> _ILIT(0) + VirtualRegD{} -> 1 + VirtualRegF{} -> 0 + _other -> 0 RcDoubleSSE -> case vr of - VirtualRegSSE{} -> _ILIT(1) - _other -> _ILIT(0) + VirtualRegSSE{} -> 1 + _other -> 0 - _other -> _ILIT(0) + _other -> 0 {-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> FastInt +realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr = case cls of RcInteger -> case rr of RealRegSingle regNo - | regNo < firstfake -> _ILIT(1) - | otherwise -> _ILIT(0) + | regNo < firstfake -> 1 + | otherwise -> 0 - RealRegPair{} -> _ILIT(0) + RealRegPair{} -> 0 RcDouble -> case rr of RealRegSingle regNo - | regNo >= firstfake && regNo <= lastfake -> _ILIT(1) - | otherwise -> _ILIT(0) + | regNo >= firstfake && regNo <= lastfake -> 1 + | otherwise -> 0 - RealRegPair{} -> _ILIT(0) + RealRegPair{} -> 0 RcDoubleSSE -> case rr of - RealRegSingle regNo | regNo >= firstxmm -> _ILIT(1) - _otherwise -> _ILIT(0) + RealRegSingle regNo | regNo >= firstxmm -> 1 + _otherwise -> 0 - _other -> _ILIT(0) + _other -> 0 -- ----------------------------------------------------------------------------- -- Immediates diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index dbeade27bc..6b012ee5ea 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -38,7 +38,6 @@ import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) import Outputable -import FastTypes import FastString import Module ( PackageKey ) @@ -56,25 +55,20 @@ These are in \tr{state-interface.verb} order. -- data PrimOp = ... #include "primop-data-decl.hs-incl" --- Used for the Ord instance - -primOpTag :: PrimOp -> Int -primOpTag op = iBox (tagOf_PrimOp op) - -- supplies --- tagOf_PrimOp :: PrimOp -> FastInt +-- primOpTag :: PrimOp -> Int #include "primop-tag.hs-incl" -tagOf_PrimOp _ = error "tagOf_PrimOp: unknown primop" +primOpTag _ = error "primOpTag: unknown primop" instance Eq PrimOp where - op1 == op2 = tagOf_PrimOp op1 ==# tagOf_PrimOp op2 + op1 == op2 = primOpTag op1 == primOpTag op2 instance Ord PrimOp where - op1 < op2 = tagOf_PrimOp op1 <# tagOf_PrimOp op2 - op1 <= op2 = tagOf_PrimOp op1 <=# tagOf_PrimOp op2 - op1 >= op2 = tagOf_PrimOp op1 >=# tagOf_PrimOp op2 - op1 > op2 = tagOf_PrimOp op1 ># tagOf_PrimOp op2 + op1 < op2 = primOpTag op1 < primOpTag op2 + op1 <= op2 = primOpTag op1 <= primOpTag op2 + op1 >= op2 = primOpTag op1 >= primOpTag op2 + op1 > op2 = primOpTag op1 > primOpTag op2 op1 `compare` op2 | op1 < op2 = LT | op1 == op2 = EQ | otherwise = GT diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs index cce8394565..f3bbd50e26 100644 --- a/compiler/profiling/CostCentre.hs +++ b/compiler/profiling/CostCentre.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} module CostCentre ( CostCentre(..), CcName, IsCafCC(..), -- All abstract except to friend: ParseIface.y @@ -26,7 +26,6 @@ import Name import Module import Unique import Outputable -import FastTypes import SrcLoc import FastString import Util @@ -87,13 +86,14 @@ cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} cmpCostCentre other_1 other_2 = let - !tag1 = tag_CC other_1 - !tag2 = tag_CC other_2 + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 in - if tag1 <# tag2 then LT else GT + if tag1 < tag2 then LT else GT where - tag_CC (NormalCC {}) = _ILIT(0) - tag_CC (AllCafsCC {}) = _ILIT(1) + tag_CC :: CostCentre -> Int + tag_CC (NormalCC {}) = 0 + tag_CC (AllCafsCC {}) = 1 ----------------------------------------------------------------------------- diff --git a/compiler/utils/FastFunctions.hs b/compiler/utils/FastFunctions.hs index 140e42949a..c643e3c8fb 100644 --- a/compiler/utils/FastFunctions.hs +++ b/compiler/utils/FastFunctions.hs @@ -1,46 +1,19 @@ {- -Z% (c) The University of Glasgow, 2000-2006 - -\section{Fast functions} -} {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} module FastFunctions ( - unsafeChr, inlinePerformIO, unsafeDupableInterleaveIO, - indexWord8OffFastPtr, - indexWord8OffFastPtrAsFastChar, indexWord8OffFastPtrAsFastInt, - global, Global + inlinePerformIO, ) where #include "HsVersions.h" -import FastTypes -import Data.IORef -import System.IO.Unsafe - import GHC.Exts -import GHC.Word -import GHC.Base (unsafeChr) - -import GHC.IO (IO(..), unsafeDupableInterleaveIO) +import GHC.IO (IO(..)) -- 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) - ---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 diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs index 40c3882b87..32482ccb0b 100644 --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -93,7 +93,6 @@ module FastString #include "HsVersions.h" import Encoding -import FastTypes import FastFunctions import Panic import Util @@ -531,8 +530,8 @@ tailFS (FastString _ _ bs _) = consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) -uniqueOfFS :: FastString -> FastInt -uniqueOfFS (FastString u _ _ _) = iUnbox u +uniqueOfFS :: FastString -> Int +uniqueOfFS (FastString u _ _ _) = u nilFS :: FastString nilFS = mkFastString "" @@ -561,23 +560,14 @@ hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs -- ----------------------------------------------------------------------------- -- LitStrings, here for convenience only. --- 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 +--data LitString = LitString {-#UNPACK#-}!Addr# {-#UNPACK#-}!Int# mkLitString# :: Addr# -> LitString mkLitString# a# = Ptr a# ---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 = @@ -594,32 +584,11 @@ mkLitString s = ) 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)) +unpackLitString (Ptr p) = unpackCString# p lengthLS :: LitString -> Int lengthLS = 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 - -lengthLS :: LitString -> Int -lengthLS = length - -#endif - -- ----------------------------------------------------------------------------- -- under the carpet diff --git a/compiler/utils/FastTypes.hs b/compiler/utils/FastTypes.hs deleted file mode 100644 index a5c1aa9637..0000000000 --- a/compiler/utils/FastTypes.hs +++ /dev/null @@ -1,138 +0,0 @@ -{- -(c) The University of Glasgow, 2000-2006 - -\section{Fast integers, etc... booleans moved to FastBool for using panic} --} - -{-# LANGUAGE CPP, MagicHash #-} - ---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...) - --- | Fast integers, characters and pointer types for use in many parts of GHC -module FastTypes ( - -- * FastInt - FastInt, - - -- ** Getting in and out of FastInt - _ILIT, iBox, iUnbox, - - -- ** Arithmetic on FastInt - (+#), (-#), (*#), 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 - - -- * FastChar - FastChar, - - -- ** Getting in and out of FastChar - _CLIT, cBox, cUnbox, - - -- ** Operations on FastChar - fastOrd, fastChr, eqFastChar, - --note, fastChr is "unsafe"Chr: it doesn't check for - --character values above the range of Unicode - - -- * FastPtr - FastPtr, - - -- ** Getting in and out of FastPtr - pBox, pUnbox, - - -- ** Casting FastPtrs - castFastPtr - ) where - -#include "HsVersions.h" - --- Import the beggars -import ExtsCompat46 - -type FastInt = Int# - ---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 - -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 -iBox :: FastInt -> Int -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 diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 948ae7d5df..93645d38fe 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -72,9 +72,9 @@ module Outputable ( mkUserStyle, cmdlineParserStyle, Depth(..), -- * Error handling and debugging utilities - pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, + pprPanic, pprSorry, assertPprPanic, pprPgmError, pprTrace, warnPprTrace, - trace, pgmError, panic, sorry, panicFastInt, assertPanic, + trace, pgmError, panic, sorry, assertPanic, pprDebugAndThen, ) where @@ -87,7 +87,6 @@ import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) import FastString -import FastTypes import qualified Pretty import Util import Platform @@ -1032,10 +1031,6 @@ pprTrace str doc x | opt_NoDebugOutput = x | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x -pprPanicFastInt :: String -> SDoc -> FastInt --- ^ Specialization of pprPanic that can be safely used with 'FastInt' -pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg - warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs index bfb9df3ad3..e1c848d540 100644 --- a/compiler/utils/Panic.hs +++ b/compiler/utils/Panic.hs @@ -17,8 +17,8 @@ module Panic ( progName, pgmError, - panic, sorry, panicFastInt, assertPanic, trace, - panicDoc, sorryDoc, panicDocFastInt, pgmErrorDoc, + panic, sorry, assertPanic, trace, + panicDoc, sorryDoc, pgmErrorDoc, Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, @@ -30,7 +30,6 @@ module Panic ( import {-# SOURCE #-} Outputable (SDoc) import Config -import FastTypes import Exception import Control.Concurrent @@ -198,16 +197,6 @@ sorryDoc x doc = throwGhcException (PprSorry x doc) pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) --- | Panic while pretending to return an unboxed int. --- You can't use the regular panic functions in expressions --- producing unboxed ints because they have the wrong kind. -panicFastInt :: String -> FastInt -panicFastInt s = case (panic s) of () -> _ILIT(0) - -panicDocFastInt :: String -> SDoc -> FastInt -panicDocFastInt s d = case (panicDoc s d) of () -> _ILIT(0) - - -- | Throw an failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a assertPanic file line = diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs index 570282da57..2e339d8d75 100644 --- a/compiler/utils/StringBuffer.hs +++ b/compiler/utils/StringBuffer.hs @@ -6,8 +6,8 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} -{-# OPTIONS_GHC -O -funbox-strict-fields #-} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -45,7 +45,6 @@ module StringBuffer import Encoding import FastString -import FastTypes import FastFunctions import Outputable import Util @@ -232,26 +231,10 @@ 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 --- 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 (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. - !ptr' = pUnbox ptr - byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i))) go i x | i == len = x - | otherwise = case byteOff i of + | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0 diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 96e911ee44..e9b9d3f3df 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -114,9 +114,7 @@ import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) -#ifdef DEBUG -import FastTypes -#endif +import GHC.Exts #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative) @@ -465,22 +463,22 @@ isn'tIn _msg x ys = x `notElem` ys # else /* DEBUG */ isIn msg x ys - = elem100 (_ILIT(0)) x ys + = elem100 0 x ys where - elem100 _ _ [] = False + elem100 :: Eq a => Int -> a -> [a] -> Bool + elem100 _ _ [] = False elem100 i x (y:ys) - | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg) - (x `elem` (y:ys)) - | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys + | i > 100 = trace ("Over-long elem in " ++ msg) (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i + 1) x ys isn'tIn msg x ys - = notElem100 (_ILIT(0)) x ys + = notElem100 0 x ys where + notElem100 :: Eq a => Int -> a -> [a] -> Bool notElem100 _ _ [] = True notElem100 i x (y:ys) - | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg) - (x `notElem` (y:ys)) - | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys + | i > 100 = trace ("Over-long notElem in " ++ msg) (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i + 1) x ys # endif /* DEBUG */ {- @@ -491,9 +489,6 @@ isn'tIn msg x ys ************************************************************************ -} -sortWith :: Ord b => (a->b) -> [a] -> [a] -sortWith get_key xs = sortBy (comparing get_key) xs - minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index d8d555cdf2..2a5218e678 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -688,8 +688,8 @@ gen_primop_tag (Info _ entries) tagOf_type : zipWith f primop_entries [1 :: Int ..]) where primop_entries = concatMap desugarVectorSpec $ filter is_primop entries - tagOf_type = "tagOf_PrimOp :: PrimOp -> FastInt" - f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ")" + tagOf_type = "primOpTag :: PrimOp -> Int" + f i n = "primOpTag " ++ cons i ++ " = " ++ show n max_def_type = "maxPrimOpTag :: Int" max_def = "maxPrimOpTag = " ++ show (length primop_entries) |