TickBox representation change

[ghc-hetmet.git] / compiler / deSugar / DsUtils.lhs

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 8c5a743..6bc70e2 100644 (file)
--- 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,45 +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, tyConArity )
-import DataCon         ( DataCon, dataConSourceArity, dataConTyCon, dataConTag, dataConRepArgTys )
-import Type            ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy,
-                          splitNewTyConApp )
-import Coercion         ( Coercion, mkUnsafeCoercion )
-import TcType          ( tcEqType )
-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}
 
@@ -887,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