Commit 8100cd43 authored by andy@galois.com's avatar andy@galois.com
Browse files

TickBox representation change

This changes the internal representation of TickBoxes,
from
        Note (TickBox "module" n)  <expr>
into

        case tick<module,n> of
          _ -> <expr>

tick has type :: #State #World, when the module and tick numbe
are stored inside IdInfo.

Binary tick boxes change from

         Note (BinaryTickBox "module" t f) <expr>

into

          btick<module,t,f> <expr>

btick has type :: Bool -> Bool, with the module and tick number
stored inside IdInfo.
parent 85900110
......@@ -33,6 +33,7 @@ module Id (
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
isBottomingId, idIsFrom,
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
-- Inline pragma stuff
......@@ -313,6 +314,19 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
| otherwise = False -- TyVars count as not dead
\end{code}
\begin{code}
isTickBoxOp :: Id -> Bool
isTickBoxOp id =
case globalIdDetails id of
TickBoxOpId tick -> True
_ -> False
isTickBoxOp_maybe :: Id -> Maybe TickBoxOp
isTickBoxOp_maybe id =
case globalIdDetails id of
TickBoxOpId tick -> Just tick
_ -> Nothing
\end{code}
%************************************************************************
%* *
......
......@@ -71,7 +71,10 @@ module IdInfo (
CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo,
-- Tick-box info
TickBoxOp(..), TickBoxId,
) where
#include "HsVersions.h"
......@@ -87,6 +90,7 @@ import TyCon
import ForeignCall
import NewDemand
import Outputable
import Module
import Data.Maybe
......@@ -215,7 +219,7 @@ seqNewDemandInfo (Just dmd) = seqDemand dmd
%************************************************************************
%* *
\subsection{GlobalIdDetails
\subsection{GlobalIdDetails}
%* *
%************************************************************************
......@@ -246,6 +250,8 @@ data GlobalIdDetails
| PrimOpId PrimOp -- The Id for a primitive operator
| FCallId ForeignCall -- The Id for a foreign call
| TickBoxOpId TickBoxOp -- The Id for a tick box (both traditional and binary)
| NotGlobalId -- Used as a convenient extra return value from globalIdDetails
notGlobalId = NotGlobalId
......@@ -258,6 +264,7 @@ instance Outputable GlobalIdDetails where
ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
ppr (TickBoxOpId _) = ptext SLIT("[TickBoxOp]")
ppr (RecordSelId {}) = ptext SLIT("[RecSel]")
\end{code}
......@@ -698,3 +705,23 @@ zapFragileInfo :: IdInfo -> Maybe IdInfo
zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo
`setUnfoldingInfo` NoUnfolding)
\end{code}
%************************************************************************
%* *
\subsection{TickBoxOp}
%* *
%************************************************************************
\begin{code}
type TickBoxId = Int
data TickBoxOp
= TickBox Module !TickBoxId -- ^Tick box for Hpc-style coverage,
-- type = State# Void#
| BinaryTickBox Module !TickBoxId !TickBoxId
-- ^Binary tick box, with a tick for result = True, result = False,
-- type = Bool -> Bool
instance Outputable TickBoxOp where
ppr (TickBox mod n) = ptext SLIT("tick") <+> ppr (mod,n)
ppr (BinaryTickBox mod t f) = ptext SLIT("btick") <+> ppr (mod,t,f)
\end{code}
......@@ -18,7 +18,7 @@ module MkId (
mkDataConIds,
mkRecordSelId,
mkPrimOpId, mkFCallId,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBinaryTickBoxOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
......@@ -72,6 +72,7 @@ import Util
import Outputable
import FastString
import ListSetOps
import Module
\end{code}
%************************************************************************
......@@ -903,6 +904,38 @@ mkFCallId uniq fcall ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
mkTickBoxOpId :: Unique
-> Module
-> TickBoxId
-> Id
mkTickBoxOpId uniq mod ix = mkGlobalId (TickBoxOpId tickbox) name ty info
where
tickbox = TickBox mod ix
occ_str = showSDoc (braces (ppr tickbox))
name = mkTickBoxOpName uniq occ_str
info = noCafIdInfo
ty = realWorldStatePrimTy
mkBinaryTickBoxOpId
:: Unique
-> Module
-> TickBoxId
-> TickBoxId
-> Id
mkBinaryTickBoxOpId uniq mod ixT ixF = mkGlobalId (TickBoxOpId tickbox) name ty info
where
tickbox = BinaryTickBox mod ixT ixF
occ_str = showSDoc (braces (ppr tickbox))
name = mkTickBoxOpName uniq occ_str
info = noCafIdInfo
`setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
ty = mkFunTy boolTy boolTy
arity = 1
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
--- ?? mkStrictSig (mkTopDmdType [seqDmd] TopRes)
\end{code}
......
......@@ -15,6 +15,7 @@ module Name (
mkInternalName, mkSystemName,
mkSystemVarName, mkSysTvName,
mkFCallName, mkIPName,
mkTickBoxOpName,
mkExternalName, mkWiredInName,
nameUnique, setNameUnique,
......@@ -220,6 +221,11 @@ mkFCallName :: Unique -> String -> Name
mkFCallName uniq str = Name { n_uniq = getKey# uniq, n_sort = Internal,
n_occ = mkVarOcc str, n_loc = noSrcLoc }
mkTickBoxOpName :: Unique -> String -> Name
mkTickBoxOpName uniq str
= Name { n_uniq = getKey# uniq, n_sort = Internal,
n_occ = mkVarOcc str, n_loc = noSrcLoc }
mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
= Name { n_uniq = getKey# uniq,
......
......@@ -23,6 +23,7 @@ import Var
import VarSet
import VarEnv
import Id
import IdInfo
import DataCon
import PrimOp
import BasicTypes
......@@ -34,6 +35,8 @@ import DynFlags
import Util
import Outputable
import TysWiredIn
import MkId
import TysPrim
\end{code}
-- ---------------------------------------------------------------------------
......@@ -334,8 +337,6 @@ exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = True
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
exprIsTrivial (Note (SCC _) e) = False
exprIsTrivial (Note (TickBox {}) e) = False
exprIsTrivial (Note (BinaryTickBox {}) e) = False
exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial (Cast e co) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
......@@ -383,21 +384,34 @@ corePrepExprFloat env (Note n@(SCC _) expr)
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
returnUs (floats, Note n expr2)
corePrepExprFloat env (Note note@(TickBox {}) expr)
corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
| Just (TickBox {}) <- isTickBoxOp_maybe id
= corePrepAnExpr env expr `thenUs` \ expr1 ->
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
return (floats, Note note expr2)
return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
corePrepExprFloat env (Note note@(BinaryTickBox m t e) expr)
-- Translate Binary tickBox into standard tickBox
corePrepExprFloat env (App (Var id) expr)
| Just (BinaryTickBox m t e) <- isTickBoxOp_maybe id
= corePrepAnExpr env expr `thenUs` \ expr1 ->
deLamFloat expr1 `thenUs` \ (floats, expr2) ->
getUniqueUs `thenUs` \ u ->
let bndr = mkSysLocal FSLIT("t") u boolTy in
getUniqueUs `thenUs` \ u1 ->
getUniqueUs `thenUs` \ u2 ->
getUniqueUs `thenUs` \ u3 ->
getUniqueUs `thenUs` \ u4 ->
getUniqueUs `thenUs` \ u5 ->
let bndr1 = mkSysLocal FSLIT("t1") u1 boolTy in
let bndr2 = mkSysLocal FSLIT("t2") u2 realWorldStatePrimTy in
let bndr3 = mkSysLocal FSLIT("t3") u3 realWorldStatePrimTy in
let tick_e = mkTickBoxOpId u4 m e in
let tick_t = mkTickBoxOpId u5 m t in
return (floats, Case expr2
bndr
bndr1
boolTy
[ (DataAlt falseDataCon, [], Note (TickBox m e) (Var falseDataConId))
, (DataAlt trueDataCon, [], Note (TickBox m t) (Var trueDataConId))
[ (DataAlt falseDataCon, [],
Case (Var tick_e) bndr2 boolTy [(DEFAULT,[],Var falseDataConId)])
, (DataAlt trueDataCon, [],
Case (Var tick_t) bndr3 boolTy [(DEFAULT,[],Var trueDataConId)])
])
corePrepExprFloat env (Note other_note expr)
......@@ -415,17 +429,34 @@ corePrepExprFloat env expr@(Lam _ _)
where
(bndrs,body) = collectBinders expr
corePrepExprFloat env (Case (Note note@(TickBox m n) expr) bndr ty alts)
= corePrepExprFloat env (Note note (Case expr bndr ty alts))
corePrepExprFloat env (Case (Note note@(BinaryTickBox m t e) expr) bndr ty alts)
= do { ASSERT(exprType expr `coreEqType` boolTy)
corePrepExprFloat env $
Case expr bndr ty
[ (DataAlt falseDataCon, [], Note (TickBox m e) falseBranch)
, (DataAlt trueDataCon, [], Note (TickBox m t) trueBranch)
-- This is an (important) optimization.
-- case <btick,A,B> e of { T -> e1 ; F -> e2 }
-- ==> case e of { T -> <tick,A> e1 ; F -> <tick,B> e2 }
-- This could move into the simplifier.
corePrepExprFloat env (Case (App (Var id) expr) bndr ty alts)
| Just (BinaryTickBox m t e) <- isTickBoxOp_maybe id
= getUniqueUs `thenUs` \ u1 ->
getUniqueUs `thenUs` \ u2 ->
getUniqueUs `thenUs` \ u3 ->
getUniqueUs `thenUs` \ u4 ->
getUniqueUs `thenUs` \ u5 ->
let bndr1 = mkSysLocal FSLIT("t1") u1 boolTy in
let bndr2 = mkSysLocal FSLIT("t2") u2 realWorldStatePrimTy in
let bndr3 = mkSysLocal FSLIT("t3") u3 realWorldStatePrimTy in
let tick_e = mkTickBoxOpId u4 m e in
let tick_t = mkTickBoxOpId u5 m t in
ASSERT (exprType expr `coreEqType` boolTy)
corePrepExprFloat env $
Case expr
bndr1
ty
[ (DataAlt falseDataCon, [],
Case (Var tick_e) bndr2 ty [(DEFAULT,[],falseBranch)])
, (DataAlt trueDataCon, [],
Case (Var tick_t) bndr3 ty [(DEFAULT,[],trueBranch)])
]
}
where
(_,_,trueBranch) = findAlt (DataAlt trueDataCon) alts
(_,_,falseBranch) = findAlt (DataAlt falseDataCon) alts
......
......@@ -60,7 +60,6 @@ import DataCon
import BasicTypes
import FastString
import Outputable
import Module
infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
......@@ -133,11 +132,6 @@ data Note
| CoreNote String -- A generic core annotation, propagated but not used by GHC
| TickBox Module !Int -- ^Tick box for Hpc-style coverage
| BinaryTickBox Module !Int !Int
-- ^Binary tick box, with a tick for result = True, result = False
-- NOTE: we also treat expressions wrapped in InlineMe as
-- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
-- What this means is that we obediently inline even things that don't
......@@ -626,9 +620,6 @@ seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqNote (CoreNote s) = s `seq` ()
seqNote (TickBox m n) = m `seq` () -- no need for seq on n, because n is strict
seqNote (BinaryTickBox m t f)
= m `seq` () -- likewise on t and f.
seqNote other = ()
seqBndr b = b `seq` ()
......
......@@ -517,7 +517,9 @@ side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
-- Tick boxes are *not* suitable for speculation
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
&& not (isTickBoxOp v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
exprOkForSpeculation other_expr
......@@ -621,10 +623,6 @@ exprIsHNF (Lit l) = True
exprIsHNF (Type ty) = True -- Types are honorary Values;
-- we don't mind copying them
exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
exprIsHNF (Note (TickBox {}) _)
= False
exprIsHNF (Note (BinaryTickBox {}) _)
= False
exprIsHNF (Note _ e) = exprIsHNF e
exprIsHNF (Cast e co) = exprIsHNF e
exprIsHNF (App e (Type _)) = exprIsHNF e
......@@ -805,6 +803,7 @@ exprIsConApp_maybe (Cast expr co)
Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
}}
{-
-- We do not want to tell the world that we have a
-- Cons, to *stop* Case of Known Cons, which removes
-- the TickBox.
......@@ -812,6 +811,7 @@ exprIsConApp_maybe (Note (TickBox {}) expr)
= Nothing
exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
= Nothing
-}
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
......@@ -1197,9 +1197,6 @@ exprArity e = go e
go (Var v) = idArity v
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Note (TickBox {}) _) = 0
go (Note (BinaryTickBox {}) _)
= 0
go (Note n e) = go e
go (Cast e _) = go e
go (App e (Type t)) = go e
......@@ -1317,9 +1314,7 @@ exprSize (Type t) = seqType t `seq` 1
noteSize (SCC cc) = cc `seq` 1
noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
noteSize (TickBox m n) = m `seq` n `seq` 1
noteSize (BinaryTickBox m t e) = m `seq` t `seq` e `seq` 1
varSize :: Var -> Int
varSize b | isTyVar b = 1
| otherwise = seqType (idType b) `seq`
......@@ -1480,8 +1475,6 @@ rhsIsStatic this_pkg rhs = is_static False rhs
is_static False (Lam b e) = isRuntimeVar b || is_static False e
is_static in_arg (Note (SCC _) e) = False
is_static in_arg (Note (TickBox {}) e) = False
is_static in_arg (Note (BinaryTickBox {}) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
is_static in_arg (Cast e co) = is_static in_arg e
......
......@@ -213,21 +213,6 @@ ppr_expr add_par (Note (SCC cc) expr)
ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
ppr_expr add_par (Note (TickBox mod n) expr)
= add_par $
sep [sep [ptext SLIT("__tick_box"),
pprModule mod,
text (show n)],
pprParendExpr expr]
ppr_expr add_par (Note (BinaryTickBox mod t e) expr)
= add_par $
sep [sep [ptext SLIT("__binary_tick_box"),
pprModule mod,
text (show t),
text (show e)],
pprParendExpr expr]
ppr_expr add_par (Note (CoreNote s) expr)
= add_par $
sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
......
......@@ -58,11 +58,23 @@ import System.Directory ( createDirectoryIfMissing )
\begin{code}
addCoverageTicksToBinds dflags mod mod_loc binds = do
{ let orig_file =
case ml_hs_file mod_loc of
Just file -> file
Nothing -> error "can not find the original file during hpc trans"
; if "boot" `isSuffixOf` orig_file then return (binds, 0)
else addCoverageTicksToBinds2 dflags mod orig_file binds
}
addCoverageTicksToBinds2 dflags mod orig_file binds = do
let main_mod = mainModIs dflags
main_is = case mainFunIs dflags of
Nothing -> "main"
Just main -> main
modTime <- getModificationTime' orig_file
let mod_name = moduleNameString (moduleName mod)
let (binds1,st)
......@@ -78,12 +90,6 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
-- write the mix entries for this module
let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
let orig_file = case ml_hs_file mod_loc of
Just file -> file
Nothing -> error "can not find the original file during hpc trans"
modTime <- getModificationTime' orig_file
createDirectoryIfMissing True hpc_dir
mixCreate hpc_dir mod_name (Mix orig_file modTime tabStop $ reverse $ mixEntries st)
......
......@@ -70,6 +70,7 @@ import Util
import ListSetOps
import FastString
import Data.Char
import DynFlags
#ifdef DEBUG
import Util
......@@ -888,11 +889,27 @@ mkOptTickBox (Just ix) e = mkTickBox ix e
mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
mkTickBox ix e = do
dflags <- getDOptsDs
uq <- newUnique
mod <- getModuleDs
return $ Note (TickBox mod ix) e
let tick = mkTickBoxOpId uq mod ix
uq2 <- newUnique
let occName = mkVarOcc "tick"
let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal?
let var = Id.mkLocalId name realWorldStatePrimTy
return $ Case (Var tick)
var
ty
[(DEFAULT,[],e)]
where
ty = exprType e
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
mod <- getModuleDs
return $ Note (BinaryTickBox mod ixT ixF) e
dflags <- getDOptsDs
uq <- newUnique
mod <- getModuleDs
let tick = mkBinaryTickBoxOpId uq mod ixT ixF
return $ App (Var tick) e
\end{code}
\ No newline at end of file
......@@ -1002,15 +1002,6 @@ instance Binary IfaceNote where
put_ bh (IfaceCoreNote s) = do
putByte bh 4
put_ bh s
put_ bh (IfaceTickBox m n) = do
putByte bh 5
put_ bh m
put_ bh n
put_ bh (IfaceBinaryTickBox m t e) = do
putByte bh 6
put_ bh m
put_ bh t
put_ bh e
get bh = do
h <- getByte bh
case h of
......@@ -1019,13 +1010,6 @@ instance Binary IfaceNote where
3 -> do return IfaceInlineMe
4 -> do ac <- get bh
return (IfaceCoreNote ac)
5 -> do m <- get bh
n <- get bh
return (IfaceTickBox m n)
6 -> do m <- get bh
t <- get bh
e <- get bh
return (IfaceBinaryTickBox m t e)
-------------------------------------------------------------------------
-- IfaceDecl and friends
......
......@@ -210,8 +210,6 @@ data IfaceExpr
data IfaceNote = IfaceSCC CostCentre
| IfaceInlineMe
| IfaceCoreNote String
| IfaceTickBox Module Int
| IfaceBinaryTickBox Module Int Int
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
-- Note: FastString, not IfaceBndr (and same with the case binder)
......@@ -485,12 +483,6 @@ instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
ppr IfaceInlineMe = ptext SLIT("__inline_me")
ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
ppr (IfaceTickBox m n) = ptext SLIT("__tick_box") <+> pprModule m <+> text (show n)
ppr (IfaceBinaryTickBox m t e)
= ptext SLIT("__binary_tick_box")
<+> pprModule m
<+> text (show t)
<+> text (show e)
instance Outputable IfaceConAlt where
......@@ -759,8 +751,6 @@ eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
eq_ifaceNote env (IfaceTickBox m1 n1) (IfaceTickBox m2 n2) = bool (m1==m2 && n1==n2)
eq_ifaceNote env (IfaceBinaryTickBox m1 t1 e1) (IfaceBinaryTickBox m2 t2 e2) = bool (m1==m2 && t1==t2 && e1 == e2)
eq_ifaceNote env _ _ = NotEqual
\end{code}
......
......@@ -1240,9 +1240,6 @@ toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
toIfaceNote (SCC cc) = IfaceSCC cc
toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
toIfaceNote (TickBox m n) = IfaceTickBox m n
toIfaceNote (BinaryTickBox m t e)
= IfaceBinaryTickBox m t e
---------------------
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r)
......
......@@ -686,8 +686,6 @@ tcIfaceExpr (IfaceNote note expr)
IfaceInlineMe -> returnM (Note InlineMe expr')
IfaceSCC cc -> returnM (Note (SCC cc) expr')
IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
IfaceTickBox m n -> returnM (Note (TickBox m n) expr')
IfaceBinaryTickBox m t e -> returnM (Note (BinaryTickBox m t e) expr')
-------------------------
tcIfaceAlt _ (IfaceDefault, names, rhs)
......
......@@ -200,7 +200,7 @@ data DynFlag
| Opt_PrintBindResult
| Opt_Haddock
| Opt_Hpc
| Opt_Hpc_Trace
| Opt_Hpc_Tracer
-- keeping stuff
| Opt_KeepHiDiffs
......@@ -1053,7 +1053,7 @@ fFlags = [
( "print-bind-result", Opt_PrintBindResult ),
( "force-recomp", Opt_ForceRecomp ),
( "hpc", Opt_Hpc ),
( "hpc-tracer", Opt_Hpc )
( "hpc-tracer", Opt_Hpc_Tracer )
]
......
......@@ -21,7 +21,8 @@ import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, idCoreRules, isGlobalId,
isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector,
idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo
idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo,
isTickBoxOp
)
import IdInfo {- loads of stuff -}
import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
......@@ -791,17 +792,13 @@ CAF list to keep track of non-collectable CAFs.
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
| is_caf || mentions_cafs || is_tick
| is_caf || mentions_cafs
= MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
is_tick = case expr of
Note (TickBox {}) _ -> True
Note (BinaryTickBox {}) _ -> True
_ -> False
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
-- knows how much eta expansion is going to be done by
......
......@@ -214,13 +214,6 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
= -- Ditto... don't float anything into an INLINE expression
mkCoLets' to_drop (Note InlineMe (fiExpr [] expr))
fiExpr to_drop (_, AnnNote note@(TickBox {}) expr)
= -- Wimp out for now
mkCoLets' to_drop (Note note (fiExpr [] expr))
fiExpr to_drop (_, AnnNote note@(BinaryTickBox {}) expr)
= -- Wimp out for now
mkCoLets' to_drop (Note note (fiExpr [] expr))
fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
= Note note (fiExpr to_drop expr)
\end{code}
......
......@@ -875,16 +875,8 @@ simplNote env InlineMe e cont
= simplExprF env e cont
simplNote env (CoreNote s) e cont
= do { e' <- simplExpr env e
; rebuild env (Note (CoreNote s) e') cont }
simplNote env note@(TickBox {}) e cont
= do { e' <- simplExpr env e
; rebuild env (Note note e') cont }
simplNote env note@(BinaryTickBox {}) e cont
= do { e' <- simplExpr env e
; rebuild env (Note note e') cont }
= simplExpr env e `thenSmpl` \ e' ->
rebuild env (Note (CoreNote s) e') cont
\end{code}
......
......@@ -317,15 +317,11 @@ coreToStgExpr (Note (SCC cc) expr)
= coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
returnLne (StgSCC cc expr2, fvs, escs) )