%
% (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}
\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]
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}
-- 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.
-- 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}
\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
-- 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
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
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)
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
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}
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
-- since we use * to combine hash values
hashFS :: FAST_STRING -> Int
-hashFS s = IBOX( uniqueOfFS s )
+hashFS s = iBox (uniqueOfFS s)
\end{code}
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
- mkUnboundName, isUnboundName,
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName, hashName,
#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}
-> 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}
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
import Util ( thenCmp )
import Outputable
import FastString ( unpackFS )
+import FastTypes
import GlaExts ( Int(..), (+#) )
\end{code}
= NoSrcLoc
| SrcLoc FAST_STRING -- A precise location (file name)
- FAST_INT
+ FastInt
| UnhelpfulSrcLoc FAST_STRING -- Just a general indication
\end{code}
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("<an interface file>")
mkBuiltinSrcLoc = UnhelpfulSrcLoc SLIT("<built-into-the-compiler>")
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}
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,
import GlaExts
import ST
import PrelBase ( Char(..), chr, ord )
+import FastTypes
import Outputable
\end{code}
\end{code}
\begin{code}
-u2i :: Unique -> FAST_INT
+u2i :: Unique -> FastInt
u2i (MkUnique i) = i
\end{code}
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}
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,
import Argv
import Constants -- Default values for some flags
import Util
+import FastTypes
import Maybes ( firstJust )
import Panic ( panic )
\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!
#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
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}
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
)
import Outputable
import CStrings ( pprStringInCStyle )
+import FastTypes
import Util ( thenCmp )
\end{code}
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
-- others
import SrcLoc ( noSrcLoc )
-import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Uniquable(..) )
import Util ( mapAccumL, seqList, thenCmp )
--- /dev/null
+%
+% (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}
module Panic ( panic, panic#, assertPanic, trace ) where
import IOExts ( trace )
+import FastTypes
#include "HsVersions.h"
\end{code}
-- 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)
#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#
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}
%************************************************************************
\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)
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)
-- 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.
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"
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
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.
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
= 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}
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)
(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)
(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)
\begin{code}
data NodeUFMData
- = NodeUFMData FAST_INT
- FAST_INT
+ = NodeUFMData FastInt
+ FastInt
\end{code}
This is the information used when computing new NodeUFMs.
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
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_ #-}
import List ( zipWith4 )
import Panic ( panic )
import IOExts ( IORef, newIORef, unsafePerformIO )
+import FastTypes
infixr 9 `thenCmp`
\end{code}
# 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 -}
projects / ghc-hetmet.git / commitdiff