X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=6bc70e2b8f56932cbe3ab2d2d3e83277ce65e896;hp=0552c2bd088ee3beb336f7618ceaacc99480b0f2;hb=8100cd4395e46ae747be4298c181a4730d6206bc;hpb=49c98d143c382a1341e1046f5ca00819a25691ba

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 0552c2b..6bc70e2 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -33,7 +33,8 @@ module DsUtils (
 	
 	dsSyntaxTable, lookupEvidence,
 
-	selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+	mkTickBox, mkOptTickBox, mkBinaryTickBox
     ) where
 
 #include "HsVersions.h"
@@ -69,6 +70,7 @@ import Util
 import ListSetOps
 import FastString
 import Data.Char
+import DynFlags
 
 #ifdef DEBUG
 import Util
@@ -880,4 +882,34 @@ mkFailurePair expr
     ty = exprType expr
 \end{code}
 
-
+\begin{code}
+mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
+mkOptTickBox Nothing e   = return e
+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
+       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
+       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