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.

4 files changed, 56 insertions, 56 deletions

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index fb31e4536d..88fa8b7612 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 <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
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 67245d1ac6..e580bed20c 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 78da0e37fa..b847df0f17 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 ab3257e80a..13c8fb7f44 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)],