From 8100cd4395e46ae747be4298c181a4730d6206bc Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Wed, 29 Nov 2006 22:09:57 +0000 Subject: [PATCH] TickBox representation change This changes the internal representation of TickBoxes, from Note (TickBox "module" n) into case tick of _ -> 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) into btick btick has type :: Bool -> Bool, with the module and tick number stored inside IdInfo. --- compiler/basicTypes/Id.lhs | 14 ++++++++ compiler/basicTypes/IdInfo.lhs | 31 +++++++++++++++-- compiler/basicTypes/MkId.lhs | 35 ++++++++++++++++++- compiler/basicTypes/Name.lhs | 6 ++++ compiler/coreSyn/CorePrep.lhs | 71 ++++++++++++++++++++++++++++----------- compiler/coreSyn/CoreSyn.lhs | 9 ----- compiler/coreSyn/CoreUtils.lhs | 17 +++------- compiler/coreSyn/PprCore.lhs | 15 --------- compiler/deSugar/Coverage.lhs | 18 ++++++---- compiler/deSugar/DsUtils.lhs | 21 ++++++++++-- compiler/iface/BinIface.hs | 16 --------- compiler/iface/IfaceSyn.lhs | 10 ------ compiler/iface/MkIface.lhs | 3 -- compiler/iface/TcIface.lhs | 2 -- compiler/main/DynFlags.hs | 4 +-- compiler/main/TidyPgm.lhs | 11 +++--- compiler/simplCore/FloatIn.lhs | 7 ---- compiler/simplCore/Simplify.lhs | 12 ++----- compiler/stgSyn/CoreToStg.lhs | 14 +++----- 19 files changed, 182 insertions(+), 134 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index cc9587e..549a58b 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -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} %************************************************************************ %* * diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 38e2a2e..9b39ccb 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -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} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index e3b40b8..8e04b55 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -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} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index feda0b1..75198bb 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -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, diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index fb31e45..88fa8b7 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -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 e of { T -> e1 ; F -> e2 } +-- ==> case e of { T -> e1 ; F -> 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 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 67245d1..e580bed 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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` () diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 78da0e3..b847df0 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -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 diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index ab3257e..13c8fb7 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -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)], diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 68bd17f..af9f002 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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 -- 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) diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 868a894..6bc70e2 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 72ea80d..782bada 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 55cd6d1..bcff5f0 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -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} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index f7cb28a..7518111 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6c60af8..4232195 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index fc3f434..2ba6172 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 ) ] diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 331d921..a8dede8 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -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 diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index b80a8e0..e32a8ea 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -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} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 28193eb..62f226c 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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} diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 64f9fe3..994b900 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -317,15 +317,11 @@ coreToStgExpr (Note (SCC cc) expr) = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> returnLne (StgSCC cc expr2, fvs, escs) ) -coreToStgExpr (Note (TickBox m n) expr) +coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)]) + | Just (TickBox m n) <- isTickBoxOp_maybe id = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> returnLne (StgTick m n expr2, fvs, escs) ) --- BinaryTickBox'es are are removed by the CorePrep pass. - -coreToStgExpr expr@(Note (BinaryTickBox m t e) _) - = pprPanic "coreToStgExpr: " (ppr expr) - coreToStgExpr (Note other_note expr) = coreToStgExpr expr @@ -451,6 +447,7 @@ coreToStgApp -> [CoreArg] -- Arguments -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) + coreToStgApp maybe_thunk_body f args = coreToStgArgs args `thenLne` \ (args', args_fvs) -> lookupVarLne f `thenLne` \ how_bound -> @@ -508,6 +505,7 @@ coreToStgApp maybe_thunk_body f args StgOpApp (StgPrimOp op) args' res_ty FCallId call -> ASSERT( saturated ) StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' in @@ -1098,8 +1096,6 @@ myCollectBinders expr where go bs (Lam b e) = go (b:bs) e go bs e@(Note (SCC _) _) = (reverse bs, e) - go bs e@(Note (TickBox {}) _) = (reverse bs, e) - go bs e@(Note (BinaryTickBox {}) _) = (reverse bs, e) go bs (Cast e co) = go bs e go bs (Note _ e) = go bs e go bs e = (reverse bs, e) @@ -1113,8 +1109,6 @@ myCollectArgs expr go (Var v) as = (v, as) go (App f a) as = go f (a:as) go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - go (Note (TickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - go (Note (BinaryTickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) go (Cast e co) as = go e as go (Note n e) as = go e as go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) -- 1.7.10.4