From 30d559930fff086ad3a8ef4162e7d748d1e96b70 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 12 Oct 2000 13:11:46 +0000 Subject: [PATCH] [project @ 2000-10-12 13:11:45 by simonmar] Move FAST_INT and FAST_BOOL into their own module FastTypes, replacing the macro definitions in HsVersions.h with real definitions. Change most of the names in the process. Now we don't get bogus imports of GlaExts all over the place, and -fwarn-unused-imports is less noisy. --- ghc/compiler/absCSyn/AbsCSyn.lhs | 64 +++++++++++------------ ghc/compiler/absCSyn/AbsCUtils.lhs | 16 +++--- ghc/compiler/absCSyn/PprAbsC.lhs | 2 +- ghc/compiler/basicTypes/Literal.lhs | 29 +++++----- ghc/compiler/basicTypes/Name.lhs | 20 ++----- ghc/compiler/basicTypes/SrcLoc.lhs | 15 +++--- ghc/compiler/basicTypes/Unique.lhs | 3 +- ghc/compiler/basicTypes/Var.lhs | 5 +- ghc/compiler/main/CmdLineOpts.lhs | 25 ++++----- ghc/compiler/prelude/PrimOp.lhs | 12 ++--- ghc/compiler/profiling/CostCentre.lhs | 7 +-- ghc/compiler/types/Type.lhs | 1 - ghc/compiler/utils/FastTypes.lhs | 57 ++++++++++++++++++++ ghc/compiler/utils/Panic.lhs | 5 +- ghc/compiler/utils/Pretty.lhs | 3 +- ghc/compiler/utils/UniqFM.lhs | 93 ++++++++++++++++----------------- ghc/compiler/utils/Util.lhs | 13 ++--- 17 files changed, 209 insertions(+), 161 deletions(-) create mode 100644 ghc/compiler/utils/FastTypes.lhs diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 5cf12fc..6bd34a6 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.33 2000/08/07 23:37:19 qrczak Exp $ +% $Id: AbsCSyn.lhs,v 1.34 2000/10/12 13:11:46 simonmar Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -374,9 +374,9 @@ mkCCostCentreStack ccs = CLbl (mkCCS_Label ccs) DataPtrRep \begin{code} data RegRelative - = HpRel FAST_INT -- } - | SpRel FAST_INT -- }- offsets in StgWords - | NodeRel FAST_INT -- } + = HpRel FastInt -- } + | SpRel FastInt -- }- offsets in StgWords + | NodeRel FastInt -- } | CIndex CAddrMode CAddrMode PrimRep -- pointer arithmetic :-) -- CIndex a b k === (k*)a[b] @@ -388,16 +388,16 @@ data ReturnInfo hpRel :: VirtualHeapOffset -- virtual offset of Hp -> VirtualHeapOffset -- virtual offset of The Thing -> RegRelative -- integer offset -hpRel IBOX(hp) IBOX(off) = HpRel (hp _SUB_ off) +hpRel _IBOX(hp) _IBOX(off) = HpRel (hp _SUB_ off) spRel :: VirtualSpOffset -- virtual offset of Sp -> VirtualSpOffset -- virtual offset of The Thing -> RegRelative -- integer offset -spRel sp off = SpRel (case spRelToInt sp off of { IBOX(i) -> i }) +spRel sp off = SpRel (case spRelToInt sp off of { _IBOX(i) -> i }) nodeRel :: VirtualHeapOffset -> RegRelative -nodeRel IBOX(off) = NodeRel off +nodeRel _IBOX(off) = NodeRel off \end{code} @@ -451,13 +451,13 @@ data MagicId -- Argument and return registers | VanillaReg -- pointers, unboxed ints and chars PrimRep - FAST_INT -- its number (1 .. mAX_Vanilla_REG) + FastInt -- its number (1 .. mAX_Vanilla_REG) | FloatReg -- single-precision floating-point registers - FAST_INT -- its number (1 .. mAX_Float_REG) + FastInt -- its number (1 .. mAX_Float_REG) | DoubleReg -- double-precision floating-point registers - FAST_INT -- its number (1 .. mAX_Double_REG) + FastInt -- its number (1 .. mAX_Double_REG) -- STG registers | Sp -- Stack ptr; points to last occupied stack location. @@ -470,14 +470,14 @@ data MagicId -- no actual register | LongReg -- long int registers (64-bit, really) PrimRep -- Int64Rep or Word64Rep - FAST_INT -- its number (1 .. mAX_Long_REG) + FastInt -- its number (1 .. mAX_Long_REG) | CurrentTSO -- pointer to current thread's TSO | CurrentNursery -- pointer to allocation area -node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node -tagreg = VanillaReg WordRep ILIT(2) -- A convenient alias for TagReg +node = VanillaReg PtrRep _ILIT(1) -- A convenient alias for Node +tagreg = VanillaReg WordRep _ILIT(2) -- A convenient alias for TagReg nodeReg = CReg node \end{code} @@ -486,26 +486,26 @@ We need magical @Eq@ because @VanillaReg@s come in multiple flavors. \begin{code} instance Eq MagicId where - reg1 == reg2 = tag reg1 _EQ_ tag reg2 + reg1 == reg2 = tag reg1 ==# tag reg2 where - tag BaseReg = (ILIT(0) :: FAST_INT) - tag Sp = ILIT(1) - tag Su = ILIT(2) - tag SpLim = ILIT(3) - tag Hp = ILIT(4) - tag HpLim = ILIT(5) - tag CurCostCentre = ILIT(6) - tag VoidReg = ILIT(7) - - tag (VanillaReg _ i) = ILIT(8) _ADD_ i - - tag (FloatReg i) = ILIT(8) _ADD_ maxv _ADD_ i - tag (DoubleReg i) = ILIT(8) _ADD_ maxv _ADD_ maxf _ADD_ i - tag (LongReg _ i) = ILIT(8) _ADD_ maxv _ADD_ maxf _ADD_ maxd _ADD_ i - - maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } - maxf = case mAX_Float_REG of { IBOX(x) -> x } - maxd = case mAX_Double_REG of { IBOX(x) -> x } + tag BaseReg = (_ILIT(0) :: FastInt) + tag Sp = _ILIT(1) + tag Su = _ILIT(2) + tag SpLim = _ILIT(3) + tag Hp = _ILIT(4) + tag HpLim = _ILIT(5) + tag CurCostCentre = _ILIT(6) + tag VoidReg = _ILIT(7) + + tag (VanillaReg _ i) = _ILIT(8) +# i + + tag (FloatReg i) = _ILIT(8) +# maxv +# i + tag (DoubleReg i) = _ILIT(8) +# maxv +# maxf +# i + tag (LongReg _ i) = _ILIT(8) +# maxv +# maxf +# maxd +# i + + maxv = iUnbox mAX_Vanilla_REG + maxf = iUnbox mAX_Float_REG + maxd = iUnbox mAX_Double_REG \end{code} Returns True for any register that {\em potentially} dies across diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index f380da9..11a26f3 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -441,7 +441,7 @@ sameAmode :: CAddrMode -> CAddrMode -> Bool -- At the moment we put in just enough to catch the cases we want: -- the second (destination) argument is always a CVal. sameAmode (CReg r1) (CReg r2) = r1 == r2 -sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 _EQ_ r2 +sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2 sameAmode other1 other2 = False doSimultaneously1 :: [CVertex] -> FlatM AbstractC @@ -520,7 +520,7 @@ other1 `conflictsWith` other2 = False regConflictsWithRR :: MagicId -> RegRelative -> Bool -regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True +regConflictsWithRR (VanillaReg k _ILIT(1)) (NodeRel _) = True regConflictsWithRR Sp (SpRel _) = True regConflictsWithRR Hp (HpRel _) = True @@ -533,14 +533,14 @@ rrConflictsWithRR :: Int -> Int -- Sizes of two things rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2 where rr (SpRel o1) (SpRel o2) - | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero - | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2 - | otherwise = (o1 _ADD_ s1) _GE_ o2 && - (o2 _ADD_ s2) _GE_ o1 + | s1 ==# _ILIT(0) || s2 ==# _ILIT(0) = False -- No conflict if either is size zero + | s1 ==# _ILIT(1) && s2 ==# _ILIT(1) = o1 ==# o2 + | otherwise = (o1 +# s1) >=# o2 && + (o2 +# s2) >=# o1 rr (NodeRel o1) (NodeRel o2) - | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero - | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2 + | s1 ==# _ILIT(0) || s2 ==# _ILIT(0) = False -- No conflict if either is size zero + | s1 ==# _ILIT(1) && s2 ==# _ILIT(1) = o1 ==# o2 | otherwise = True -- Give up rr (HpRel _) (HpRel _) = True -- Give up (ToDo) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index b5221e9..2ad4595 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1277,7 +1277,7 @@ pprMagicId HpLim = ptext SLIT("HpLim") pprMagicId CurCostCentre = ptext SLIT("CCCS") pprMagicId VoidReg = panic "pprMagicId:VoidReg!" -pprVanillaReg :: FAST_INT -> SDoc +pprVanillaReg :: FastInt -> SDoc pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) pprUnionTag :: PrimRep -> SDoc diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index d2f6509..62a9c30 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -30,9 +30,10 @@ import PprType ( pprParendType ) import CStrings ( pprFSInCStyle ) import Outputable +import FastTypes import Util ( thenCmp ) -import Ratio ( numerator, denominator ) +import Ratio ( numerator ) import FastString ( uniqueOfFS ) import Char ( ord, chr ) \end{code} @@ -239,20 +240,20 @@ 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 (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d) -cmpLit lit1 lit2 | litTag lit1 _LT_ litTag lit2 = LT +cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT | otherwise = GT -litTag (MachChar _) = ILIT(1) -litTag (MachStr _) = ILIT(2) -litTag (MachAddr _) = 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 (MachLitLit _ _) = ILIT(11) +litTag (MachChar _) = _ILIT(1) +litTag (MachStr _) = _ILIT(2) +litTag (MachAddr _) = _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 (MachLitLit _ _) = _ILIT(11) \end{code} Printing @@ -358,5 +359,5 @@ hashInteger i = 1 + abs (fromInteger (i `rem` 10000)) -- since we use * to combine hash values hashFS :: FAST_STRING -> Int -hashFS s = IBOX( uniqueOfFS s ) +hashFS s = iBox (uniqueOfFS s) \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index dba3c5d..a645419 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -14,7 +14,6 @@ module Name ( mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, - mkUnboundName, isUnboundName, maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, hashName, @@ -50,21 +49,20 @@ module Name ( #include "HsVersions.h" -import {-# SOURCE #-} Var ( Id, setIdName ) -import {-# SOURCE #-} TyCon ( TyCon, setTyConName ) +import {-# SOURCE #-} Var ( Id ) +import {-# SOURCE #-} TyCon ( TyCon ) import OccName -- All of it import Module ( Module, moduleName, pprModule, mkVanillaModule, isLocalModule ) import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) -import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) +import SrcLoc ( noSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), u2i, hasKey, pprUnique ) -import PrelNames ( unboundKey ) import Maybes ( expectJust ) +import FastTypes import UniqFM import Outputable -import GlaExts \end{code} @@ -180,14 +178,6 @@ mkDerivedName :: (OccName -> OccName) -> Name -- Result is always a value name mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = name `hasKey` unboundKey \end{code} \begin{code} @@ -413,7 +403,7 @@ isExternallyVisibleName :: Name -> Bool hashName :: Name -> Int -hashName name = IBOX( u2i (nameUnique name) ) +hashName name = iBox (u2i (nameUnique name)) nameUnique name = n_uniq name nameOccName name = n_occ name diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 3dccd51..5eaf8e6 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -32,6 +32,7 @@ module SrcLoc ( import Util ( thenCmp ) import Outputable import FastString ( unpackFS ) +import FastTypes import GlaExts ( Int(..), (+#) ) \end{code} @@ -48,7 +49,7 @@ data SrcLoc = NoSrcLoc | SrcLoc FAST_STRING -- A precise location (file name) - FAST_INT + FastInt | UnhelpfulSrcLoc FAST_STRING -- Just a general indication \end{code} @@ -67,7 +68,7 @@ rare case. Things to make 'em: \begin{code} noSrcLoc = NoSrcLoc -mkSrcLoc x IBOX(y) = SrcLoc x y +mkSrcLoc x y = SrcLoc x (iUnbox y) mkIfaceSrcLoc = UnhelpfulSrcLoc SLIT("") mkBuiltinSrcLoc = UnhelpfulSrcLoc SLIT("") @@ -79,14 +80,14 @@ isNoSrcLoc other = False srcLocFile :: SrcLoc -> FAST_STRING srcLocFile (SrcLoc fname _) = fname -srcLocLine :: SrcLoc -> FAST_INT +srcLocLine :: SrcLoc -> FastInt srcLocLine (SrcLoc _ l) = l incSrcLine :: SrcLoc -> SrcLoc incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#) incSrcLine loc = loc -replaceSrcLine :: SrcLoc -> FAST_INT -> SrcLoc +replaceSrcLine :: SrcLoc -> FastInt -> SrcLoc replaceSrcLine (SrcLoc s _) l = SrcLoc s l \end{code} @@ -124,12 +125,12 @@ instance Outputable SrcLoc where ppr (SrcLoc src_path src_line) = getPprStyle $ \ sty -> if userStyle sty then - hcat [ text src_file, char ':', int IBOX(src_line) ] + hcat [ text src_file, char ':', int (iBox src_line) ] else if debugStyle sty then - hcat [ ptext src_path, char ':', int IBOX(src_line) ] + hcat [ ptext src_path, char ':', int (iBox src_line) ] else - hcat [text "{-# LINE ", int IBOX(src_line), space, + hcat [text "{-# LINE ", int (iBox src_line), space, char '\"', ptext src_path, text " #-}"] where src_file = unpackFS src_path -- Leave the directory prefix intact, diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index dda19bf..e8b4e38 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -52,6 +52,7 @@ import FastString ( FastString, uniqueOfFS ) import GlaExts import ST import PrelBase ( Char(..), chr, ord ) +import FastTypes import Outputable \end{code} @@ -70,7 +71,7 @@ data Unique = MkUnique Int# \end{code} \begin{code} -u2i :: Unique -> FAST_INT +u2i :: Unique -> FastInt u2i (MkUnique i) = i \end{code} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 72422f8..89bef36 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -39,14 +39,13 @@ import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique, mkSysLocalName, isExternallyVisibleName ) -import BasicTypes ( Unused ) +import FastTypes import Outputable import IOExts ( IORef, newIORef, readIORef, writeIORef ) \end{code} - %************************************************************************ %* * \subsection{The main data type declarations} @@ -63,7 +62,7 @@ in its @VarDetails@. data Var = Var { varName :: Name, - realUnique :: Int#, -- Key for fast comparison + realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed varType :: Type, diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 7b68e68..34e8882 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -161,6 +161,7 @@ import GlaExts import Argv import Constants -- Default values for some flags import Util +import FastTypes import Maybes ( firstJust ) import Panic ( panic ) @@ -641,18 +642,18 @@ These things behave just like enumeration types. \begin{code} instance Eq SimplifierSwitch where - a == b = tagOf_SimplSwitch a _EQ_ tagOf_SimplSwitch b + a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b instance Ord SimplifierSwitch where - a < b = tagOf_SimplSwitch a _LT_ tagOf_SimplSwitch b - a <= b = tagOf_SimplSwitch a _LE_ tagOf_SimplSwitch b + a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b + a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b -tagOf_SimplSwitch (SimplInlinePhase _) = ILIT(1) -tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(2) -tagOf_SimplSwitch DontApplyRules = ILIT(3) -tagOf_SimplSwitch SimplLetToCase = ILIT(4) -tagOf_SimplSwitch NoCaseOfCase = ILIT(5) +tagOf_SimplSwitch (SimplInlinePhase _) = _ILIT(1) +tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(2) +tagOf_SimplSwitch DontApplyRules = _ILIT(3) +tagOf_SimplSwitch SimplLetToCase = _ILIT(4) +tagOf_SimplSwitch NoCaseOfCase = _ILIT(5) -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! @@ -700,9 +701,9 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* #endif } where - mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl) - mk_assoc_elem k@(SimplInlinePhase n) = (IBOX(tagOf_SimplSwitch k), SwInt n) - mk_assoc_elem k = (IBOX(tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! + mk_assoc_elem k@(MaxSimplifierIterations lvl) = (_IBOX(tagOf_SimplSwitch k), SwInt lvl) + mk_assoc_elem k@(SimplInlinePhase n) = (_IBOX(tagOf_SimplSwitch k), SwInt n) + mk_assoc_elem k = (_IBOX(tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom! -- cannot have duplicates if we are going to use the array thing rm_dups switches_so_far switch @@ -711,7 +712,7 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* else switch : switches_so_far where sw `is_elem` [] = False - sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) _EQ_ (tagOf_SimplSwitch s) + sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s) || sw `is_elem` ss \end{code} diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 7ebb079..bf2aaea 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -73,19 +73,19 @@ primOpTag :: PrimOp -> Int primOpTag op = IBOX( tagOf_PrimOp op ) -- supplies --- tagOf_PrimOp :: PrimOp -> FAST_INT +-- tagOf_PrimOp :: PrimOp -> FastInt #include "primop-tag.hs-incl" tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op) instance Eq PrimOp where - op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2 + op1 == op2 = tagOf_PrimOp op1 ==# tagOf_PrimOp op2 instance Ord PrimOp where - op1 < op2 = tagOf_PrimOp op1 _LT_ tagOf_PrimOp op2 - op1 <= op2 = tagOf_PrimOp op1 _LE_ tagOf_PrimOp op2 - op1 >= op2 = tagOf_PrimOp op1 _GE_ tagOf_PrimOp op2 - op1 > op2 = tagOf_PrimOp op1 _GT_ 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 = tagOf_PrimOp op1 ># tagOf_PrimOp op2 op1 `compare` op2 | op1 < op2 = LT | op1 == op2 = EQ | otherwise = GT diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 9495140..78642e2 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -36,6 +36,7 @@ import Module ( Module, ModuleName, moduleName, ) import Outputable import CStrings ( pprStringInCStyle ) +import FastTypes import Util ( thenCmp ) \end{code} @@ -267,10 +268,10 @@ cmpCostCentre other_1 other_2 tag1 = tag_CC other_1 tag2 = tag_CC other_2 in - if tag1 _LT_ tag2 then LT else GT + if tag1 <# tag2 then LT else GT where - tag_CC (NormalCC {}) = (ILIT(1) :: FAST_INT) - tag_CC (AllCafsCC {}) = ILIT(2) + tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt) + tag_CC (AllCafsCC {}) = _ILIT 2 cmp_caf NotCafCC CafCC = LT cmp_caf NotCafCC NotCafCC = EQ diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index ef37be2..b3134f5 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -103,7 +103,6 @@ import TyCon ( TyCon, -- others import SrcLoc ( noSrcLoc ) -import Maybes ( maybeToBool ) import PrimRep ( PrimRep(..), isFollowableRep ) import Unique ( Uniquable(..) ) import Util ( mapAccumL, seqList, thenCmp ) diff --git a/ghc/compiler/utils/FastTypes.lhs b/ghc/compiler/utils/FastTypes.lhs new file mode 100644 index 0000000..07df3c3 --- /dev/null +++ b/ghc/compiler/utils/FastTypes.lhs @@ -0,0 +1,57 @@ +% +% (c) The University of Glasgow, 2000 +% +\section{Fast integers and booleans} + +\begin{code} +module FastTypes ( + FastInt, _ILIT, iBox, iUnbox, + (+#), (-#), (*#), quotFastInt, negateFastInt, + (==#), (<#), (<=#), (>=#), (>#), + + FastBool, fastBool, _IS_TRUE_ + ) where + +#if defined(__GLASGOW_HASKELL__) + +-- Import the beggars +import GlaExts + ( Int(..), Int#, (+#), (-#), (*#), + quotInt#, negateInt#, (==#), (<#), (<=#), (>=#), (>#) + ) + +type FastInt = Int# +_ILIT (I# x) = x +iBox x = I# x +iUnbox (I# x) = x +quotFastInt = quotInt# +negateFastInt = negateInt# + +type FastBool = Int# +fastBool True = 1# +fastBool False = 0# +_IS_TRUE_ x = x ==# 1# + +#else {- ! __GLASGOW_HASKELL__ -} + +type FastInt = Int +_ILIT x = x +iBox x = x +iUnbox x = x +(+#) = (+) +(-#) = (-) +(*#) = (*) +quotFastInt = quot +negateFastInt = negate +(==#) = (==) +(<#) = (<) +(<=#) = (<=) +(>=#) = (>=) +(>#) = (>) + +type FastBool = Bool +fastBool x = x +_IS_TRUE_ x = x + +#endif {- ! __GLASGOW_HASKELL__ -} +\end{code} diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs index 907d8aa..1a7e90b 100644 --- a/ghc/compiler/utils/Panic.lhs +++ b/ghc/compiler/utils/Panic.lhs @@ -12,6 +12,7 @@ some unnecessary loops in the module dependency graph. module Panic ( panic, panic#, assertPanic, trace ) where import IOExts ( trace ) +import FastTypes #include "HsVersions.h" \end{code} @@ -27,8 +28,8 @@ panic x = error ("panic! (the `impossible' happened):\n\t" -- what TAG_ is with GHC at the moment. Ugh. (Simon) -- No, man -- Too Beautiful! (Will) -panic# :: String -> FAST_INT -panic# s = case (panic s) of () -> ILIT(0) +panic# :: String -> FastInt +panic# s = case (panic s) of () -> _ILIT 0 assertPanic :: String -> Int -> a assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line) diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 6e24448..984655d 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -204,12 +204,13 @@ allow you to use either GHC or Hugs. To get GHC, just set the CPP variable #if defined(__GLASGOW_HASKELL__) - -- Glasgow Haskell -- Disable ASSERT checks; they are expensive! #define LOCAL_ASSERT(x) +#define ILIT(x) (x#) +#define IBOX(x) (I# (x)) #define INT Int# #define MINUS -# #define NEGATE negateInt# diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index fbea784..124d6be 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -51,13 +51,8 @@ import {-# SOURCE #-} Name ( Name ) import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily ) import Panic import GlaExts -- Lots of Int# operations +import FastTypes import Outputable - -#if ! OMIT_NATIVE_CODEGEN -#define IF_NCG(a) a -#else -#define IF_NCG(a) {--} -#endif \end{code} %************************************************************************ @@ -193,9 +188,9 @@ First, the DataType itself; which is either a Node, a Leaf, or an Empty. \begin{code} data UniqFM ele = EmptyUFM - | LeafUFM FAST_INT ele - | NodeUFM FAST_INT -- the switching - FAST_INT -- the delta + | LeafUFM FastInt ele + | NodeUFM FastInt -- the switching + FastInt -- the delta (UniqFM ele) (UniqFM ele) @@ -275,11 +270,11 @@ delete fm key = del_ele fm del_ele :: UniqFM a -> UniqFM a del_ele lf@(LeafUFM j _) - | j _EQ_ key = EmptyUFM + | j ==# key = EmptyUFM | otherwise = lf -- no delete! del_ele nd@(NodeUFM j p t1 t2) - | j _GT_ key + | j ># key = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2 | otherwise = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2) @@ -537,8 +532,8 @@ isNullUFM _ = False -- hashing is used in VarSet.uniqAway, and should be fast -- We use a cheap and cheerful method for now hashUFM EmptyUFM = 0 -hashUFM (NodeUFM n _ _ _) = IBOX(n) -hashUFM (LeafUFM n _) = IBOX(n) +hashUFM (NodeUFM n _ _ _) = iBox n +hashUFM (LeafUFM n _) = iBox n \end{code} looking up in a hurry is the {\em whole point} of this binary tree lark. @@ -568,10 +563,10 @@ lookUp fm i = lookup_tree fm lookup_tree :: UniqFM a -> Maybe a lookup_tree (LeafUFM j b) - | j _EQ_ i = Just b + | j ==# i = Just b | otherwise = Nothing lookup_tree (NodeUFM j p t1 t2) - | j _GT_ i = lookup_tree t1 + | j ># i = lookup_tree t1 | otherwise = lookup_tree t2 lookup_tree EmptyUFM = panic "lookup Failed" @@ -584,7 +579,7 @@ eltsUFM fm = foldUFM (:) [] fm ufmToList fm = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm -keysUFM fm = fold_tree (\ iu elt rest -> IBOX(iu) : rest) [] fm +keysUFM fm = fold_tree (\ iu elt rest -> iBox iu : rest) [] fm fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1 fold_tree f a (LeafUFM iu obj) = f iu obj a @@ -609,7 +604,7 @@ If in doubt, use mkSSNodeUFM, which has the `strongest' functionality, but may do a few needless evaluations. \begin{code} -mkLeafUFM :: FAST_INT -> a -> UniqFM a +mkLeafUFM :: FastInt -> a -> UniqFM a mkLeafUFM i a = LeafUFM i a -- The *ONLY* ways of building a NodeUFM. @@ -617,21 +612,21 @@ mkLeafUFM i a = LeafUFM i a mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2 mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1 mkSSNodeUFM (NodeUFMData j p) t1 t2 - = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2) NodeUFM j p t1 t2 mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2 mkSLNodeUFM (NodeUFMData j p) t1 t2 - = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2) NodeUFM j p t1 t2 mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1 mkLSNodeUFM (NodeUFMData j p) t1 t2 - = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2) NodeUFM j p t1 t2 mkLLNodeUFM (NodeUFMData j p) t1 t2 - = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + = ASSERT(correctNodeUFM (iBox j) (iBox p) t1 t2) NodeUFM j p t1 t2 correctNodeUFM @@ -645,9 +640,9 @@ correctNodeUFM j p t1 t2 = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2 where correct low high _ (LeafUFM i _) - = low <= IBOX(i) && IBOX(i) <= high + = low <= iBox i && iBox i <= high correct low high above_p (NodeUFM j p _ _) - = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p) + = low <= iBox j && iBox j <= high && above_p > iBox p correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree" \end{code} @@ -658,20 +653,20 @@ and if necessary do $\lambda$ lifting on our functions that are bound. insert_ele :: (a -> a -> a) -> UniqFM a - -> FAST_INT + -> FastInt -> a -> UniqFM a insert_ele f EmptyUFM i new = mkLeafUFM i new insert_ele f (LeafUFM j old) i new - | j _GT_ i = + | j ># i = mkLLNodeUFM (getCommonNodeUFMData (indexToRoot i) (indexToRoot j)) (mkLeafUFM i new) (mkLeafUFM j old) - | j _EQ_ i = mkLeafUFM j (f old new) + | j ==# i = mkLeafUFM j (f old new) | otherwise = mkLLNodeUFM (getCommonNodeUFMData (indexToRoot i) @@ -680,8 +675,8 @@ insert_ele f (LeafUFM j old) i new (mkLeafUFM i new) insert_ele f n@(NodeUFM j p t1 t2) i a - | i _LT_ j - = if (i _GE_ (j _SUB_ p)) + | i <# j + = if (i >=# (j -# p)) then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2 else mkLLNodeUFM (getCommonNodeUFMData (indexToRoot i) @@ -689,7 +684,7 @@ insert_ele f n@(NodeUFM j p t1 t2) i a (mkLeafUFM i a) n | otherwise - = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p)) + = if (i <=# ((j -# _ILIT(1)) +# p)) then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a) else mkLLNodeUFM (getCommonNodeUFMData (indexToRoot i) @@ -732,8 +727,8 @@ consumer use. \begin{code} data NodeUFMData - = NodeUFMData FAST_INT - FAST_INT + = NodeUFMData FastInt + FastInt \end{code} This is the information used when computing new NodeUFMs. @@ -751,43 +746,43 @@ data CommonRoot This specifies the relationship between NodeUFMData and CalcNodeUFMData. \begin{code} -indexToRoot :: FAST_INT -> NodeUFMData +indexToRoot :: FastInt -> NodeUFMData indexToRoot i = let - l = (ILIT(1) :: FAST_INT) + l = (_ILIT(1) :: FastInt) in - NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l + NodeUFMData (((i `shiftR_` l) `shiftL_` l) +# _ILIT(1)) l getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2) - | p _EQ_ p2 = getCommonNodeUFMData_ p j j2 - | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2 - | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2)) + | p ==# p2 = getCommonNodeUFMData_ p j j2 + | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2 + | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2)) where - l = (ILIT(1) :: FAST_INT) - j = i _QUOT_ (p `shiftL_` l) - j2 = i2 _QUOT_ (p2 `shiftL_` l) + l = (_ILIT(1) :: FastInt) + j = i `quotFastInt` (p `shiftL_` l) + j2 = i2 `quotFastInt` (p2 `shiftL_` l) - getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData + getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData getCommonNodeUFMData_ p j j_ - | j _EQ_ j_ - = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p + | j ==# j_ + = NodeUFMData (((j `shiftL_` l) +# l) *# p) p | otherwise = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l) ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2) - | j _EQ_ j2 = SameRoot + | j ==# j2 = SameRoot | otherwise = case getCommonNodeUFMData x y of nd@(NodeUFMData j3 p3) - | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2)) - | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2)) - | otherwise -> NewRoot nd (j _GT_ j2) + | j3 ==# j -> LeftRoot (decideSide (j ># j2)) + | j3 ==# j2 -> RightRoot (decideSide (j <# j2)) + | otherwise -> NewRoot nd (j ># j2) where decideSide :: Bool -> Side decideSide True = Leftt @@ -799,8 +794,8 @@ This might be better in Util.lhs ? Now the bit twiddling functions. \begin{code} -shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT -shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT +shiftL_ :: FastInt -> FastInt -> FastInt +shiftR_ :: FastInt -> FastInt -> FastInt #if __GLASGOW_HASKELL__ {-# INLINE shiftL_ #-} diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index ba730e9..0f3d2a0 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -61,6 +61,7 @@ module Util ( import List ( zipWith4 ) import Panic ( panic ) import IOExts ( IORef, newIORef, unsafePerformIO ) +import FastTypes infixr 9 `thenCmp` \end{code} @@ -249,20 +250,20 @@ notElem__ x (y:ys) = x /= y && notElem__ x ys # else {- DEBUG -} isIn msg x ys - = elem ILIT(0) x ys + = elem (_ILIT 0) x ys where elem i _ [] = False elem i x (y:ys) - | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg) - | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys + | i ># _ILIT 100 = panic ("Over-long elem in: " ++ msg) + | otherwise = x == y || elem (i +# _ILIT(1)) x ys isn'tIn msg x ys - = notElem ILIT(0) x ys + = notElem (_ILIT 0) x ys where notElem i x [] = True notElem i x (y:ys) - | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg) - | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys + | i ># _ILIT 100 = panic ("Over-long notElem in: " ++ msg) + | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys # endif {- DEBUG -} -- 1.7.10.4