Removing explicit Binary Tick Boxes; using Case instead.

diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs
index 3261adf..02ef0db 100644 (file)
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -720,10 +720,7 @@ 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 a640445..7d95266 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -18,7 +18,7 @@ module MkId (
 
        mkDataConIds,
        mkRecordSelId, 
-       mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBinaryTickBoxOpId,
+       mkPrimOpId, mkFCallId, mkTickBoxOpId, 
 
        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         mkUnpackCase, mkProductBox,
@@ -916,26 +916,6 @@ mkTickBoxOpId uniq mod ix =  mkGlobalId (TickBoxOpId tickbox) name ty info
     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/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 88fa8b7..e2b6ecf 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -390,30 +390,6 @@ corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
     deLamFloat expr1                   `thenUs` \ (floats, expr2) ->
     return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)])
 
--- 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` \ 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
-                       bndr1
-                       boolTy
-                       [ (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)
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr') ->
     returnUs (floats, Note other_note expr')
@@ -429,38 +405,6 @@ corePrepExprFloat env expr@(Lam _ _)
   where
     (bndrs,body) = collectBinders expr
 
--- 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
-
 corePrepExprFloat env (Case scrut bndr ty alts)
   = corePrepExprFloat env scrut                `thenUs` \ (floats1, scrut1) ->
     deLamFloat scrut1                  `thenUs` \ (floats2, scrut2) ->

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 6bc70e2..209a094 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -889,7 +889,6 @@ mkOptTickBox (Just ix) e = mkTickBox ix e
 
 mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
 mkTickBox ix e = do
-       dflags <- getDOptsDs
        uq <- newUnique         
        mod <- getModuleDs
        let tick = mkTickBoxOpId uq mod ix
@@ -907,9 +906,13 @@ mkTickBox ix e = do
 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 mkBinaryTickBox ixT ixF e = do
        mod <- getModuleDs
-       dflags <- getDOptsDs
        uq <- newUnique         
        mod <- getModuleDs
-       let tick = mkBinaryTickBoxOpId uq mod ixT ixF
-       return $ App (Var tick) e
+       let bndr1 = mkSysLocal FSLIT("t1") uq boolTy 
+       falseBox <- mkTickBox ixF $ Var falseDataConId
+       trueBox  <- mkTickBox ixT $ Var trueDataConId
+       return $ Case e bndr1 boolTy
+                       [ (DataAlt falseDataCon, [], falseBox)
+                       , (DataAlt trueDataCon,  [], trueBox)
+                       ]
 \end{code}
\ No newline at end of file