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

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index e2334f3..6bc70e2 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[DsUtils]{Utilities for desugaring}
+
+Utilities for desugaring
 
 This module exports some utility functions of no great interest.
 
@@ -31,7 +33,8 @@ module DsUtils (
 	
 	dsSyntaxTable, lookupEvidence,
 
-	selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+	mkTickBox, mkOptTickBox, mkBinaryTickBox
     ) where
 
 #include "HsVersions.h"
@@ -40,44 +43,37 @@ import {-# SOURCE #-}	Match ( matchSimply )
 import {-# SOURCE #-}	DsExpr( dsExpr )
 
 import HsSyn
-import TcHsSyn		( hsLPatType, hsPatType )
+import TcHsSyn
 import CoreSyn
-import Constants	( mAX_TUPLE_SIZE )
+import Constants
 import DsMonad
 
-import CoreUtils	( exprType, mkIfThenElse, mkCoerce, bindNonRec )
-import MkId		( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, unwrapNewTypeBody )
-import Id		( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
-import Var		( Var )
-import Name		( Name )
-import Literal		( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
-import TyCon		( isNewTyCon, tyConDataCons )
-import DataCon		( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
-import Type		( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy,
-                          splitNewTyConApp )
-import Coercion         ( mkUnsafeCoercion )
-import TysPrim		( intPrimTy )
-import TysWiredIn	( nilDataCon, consDataCon, 
-                          tupleCon, mkTupleTy,
-			  unitDataConId, unitTy,
-                          charTy, charDataCon, 
-                          intTy, intDataCon, 
-			  isPArrFakeCon )
-import BasicTypes	( Boxity(..) )
-import UniqSet		( mkUniqSet, minusUniqSet, isEmptyUniqSet )
-import UniqSupply	( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
-import PrelNames	( unpackCStringName, unpackCStringUtf8Name, 
-			  plusIntegerName, timesIntegerName, smallIntegerDataConName, 
-			  lengthPName, indexPName )
+import CoreUtils
+import MkId
+import Id
+import Var
+import Name
+import Literal
+import TyCon
+import DataCon
+import Type
+import Coercion
+import TysPrim
+import TysWiredIn
+import BasicTypes
+import UniqSet
+import UniqSupply
+import PrelNames
 import Outputable
-import SrcLoc		( Located(..), unLoc )
-import Util             ( isSingleton, zipEqual, sortWith )
-import ListSetOps	( assocDefault )
+import SrcLoc
+import Util
+import ListSetOps
 import FastString
-import Data.Char	( ord )
+import Data.Char
+import DynFlags
 
 #ifdef DEBUG
-import Util		( notNull )	-- Used in an assertion
+import Util
 #endif
 \end{code}
 
@@ -886,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