From 7eb8be6b5fcd80c4d9dfde6990dcb9fec4062d6b Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Wed, 13 Dec 2006 18:45:02 +0000 Subject: [PATCH] Removing explicit Binary Tick Boxes; using Case instead. --- compiler/basicTypes/IdInfo.lhs | 5 +-- compiler/basicTypes/MkId.lhs | 22 +------------ compiler/coreSyn/CorePrep.lhs | 56 ---------------------------------- compiler/deSugar/DsUtils.lhs | 11 ++++--- 4 files changed, 9 insertions(+), 85 deletions(-) diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 3261adf5ed78..02ef0db1429b 100644 --- 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 a6404455e84b..7d95266da4b1 100644 --- 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 88fa8b761290..e2b6ecffea83 100644 --- 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 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 - 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 6bc70e2b8f56..209a0949bfc2 100644 --- 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