Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Removing explicit Binary Tick Boxes; using Case instead.
  • Loading branch information
andy@galois.com committed Dec 13, 2006
1 parent a2fcf3a commit 7eb8be6
Show file tree
Hide file tree
Showing 4 changed files with 9 additions and 85 deletions.
5 changes: 1 addition & 4 deletions compiler/basicTypes/IdInfo.lhs
Expand Up @@ -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}
22 changes: 1 addition & 21 deletions compiler/basicTypes/MkId.lhs
Expand Up @@ -18,7 +18,7 @@ module MkId (
mkDataConIds,
mkRecordSelId,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBinaryTickBoxOpId,
mkPrimOpId, mkFCallId, mkTickBoxOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
Expand Down Expand Up @@ -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}
Expand Down
56 changes: 0 additions & 56 deletions compiler/coreSyn/CorePrep.lhs
Expand Up @@ -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')
Expand All @@ -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) ->
Expand Down
11 changes: 7 additions & 4 deletions compiler/deSugar/DsUtils.lhs
Expand Up @@ -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
Expand All @@ -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}

0 comments on commit 7eb8be6

Please sign in to comment.