From e04f49034968322349e0f3f608e1b5a856fd6521 Mon Sep 17 00:00:00 2001
From: "andy@galois.com" <unknown>
Date: Wed, 11 Jul 2007 07:20:02 +0000
Subject: [PATCH] Adding tick boxes to the interface syntax; fixes #1510

---
 compiler/iface/BinIface.hs  |    7 +++++++
 compiler/iface/IfaceEnv.lhs |   18 ++++++++++++++++++
 compiler/iface/IfaceSyn.lhs |    4 ++++
 compiler/iface/MkIface.lhs  |    2 ++
 compiler/iface/TcIface.lhs  |    4 ++++
 5 files changed, 35 insertions(+)

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 392873b..d852559 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -889,6 +889,10 @@ instance Binary IfaceExpr where
             putByte bh 11
             put_ bh ie
             put_ bh ico
+    put_ bh (IfaceTick m ix) = do
+            putByte bh 12
+            put_ bh m
+            put_ bh ix
     get bh = do
 	    h <- getByte bh
 	    case h of
@@ -928,6 +932,9 @@ instance Binary IfaceExpr where
               11 -> do ie <- get bh
                        ico <- get bh
                        return (IfaceCast ie ico)
+              12 -> do m <- get bh
+                       ix <- get bh
+                       return (IfaceTick m ix)
 
 instance Binary IfaceConAlt where
     put_ bh IfaceDefault = do
diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index acdddb6..d62aad1 100644
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -8,6 +8,7 @@ module IfaceEnv (
 	newIfaceName, newIfaceNames,
 	extendIfaceIdEnv, extendIfaceTyVarEnv, 
 	tcIfaceLclId,     tcIfaceTyVar, 
+	tcIfaceTick,
 
 	ifaceExportNames,
 
@@ -34,6 +35,7 @@ import UniqSupply
 import FiniteMap
 import BasicTypes
 import SrcLoc
+import MkId
 
 import Outputable
 \end{code}
@@ -300,3 +302,19 @@ newIfaceNames occs
 	; return [ mkInternalName uniq occ noSrcSpan
 		 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
 \end{code}
+
+%************************************************************************
+%*									*
+		(Re)creating tick boxes
+%*									*
+%************************************************************************
+
+\begin{code}
+tcIfaceTick :: Module -> Int -> IfL Id
+tcIfaceTick modName tickNo 
+  = do { uniq <- newUnique
+       ; return $ mkTickBoxOpId uniq modName tickNo
+       }
+\end{code}
+
+
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 1e9e00f..f6a5cad 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -39,6 +39,7 @@ import ForeignCall
 import BasicTypes
 import Outputable
 import FastString
+import Module
 
 import Data.List
 import Data.Maybe
@@ -208,6 +209,7 @@ data IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLit	Literal
   | IfaceFCall	ForeignCall IfaceType
+  | IfaceTick   Module Int
 
 data IfaceNote = IfaceSCC CostCentre
 	       | IfaceInlineMe
@@ -520,6 +522,7 @@ pprIfaceExpr add_par (IfaceLcl v)       = ppr v
 pprIfaceExpr add_par (IfaceExt v)       = ppr v
 pprIfaceExpr add_par (IfaceLit l)       = ppr l
 pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
+pprIfaceExpr add_par (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceExpr add_par (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
 
 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
@@ -815,6 +818,7 @@ eq_ifaceExpr env (IfaceLcl v1)	      (IfaceLcl v2)	   = eqIfOcc env v1 v2
 eq_ifaceExpr env (IfaceExt v1)	      (IfaceExt v2)	   = eqIfExt v1 v2
 eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2) 	   = bool (l1 == l2)
 eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
+eq_ifaceExpr env (IfaceTick m1 ix1)   (IfaceTick m2 ix2)   = bool (m1==m2) &&& bool (ix1 == ix2)
 eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)	   = eq_ifType env ty1 ty2
 eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
 eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 22fd309..8213cb1 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1359,6 +1359,8 @@ toIfaceVar v
   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
 	  -- Foreign calls have special syntax
   | isExternalName name		    = IfaceExt name
+  | Just (TickBox m ix) <- isTickBoxOp_maybe v
+				    = IfaceTick m ix
   | otherwise			    = IfaceLcl (getFS name)
   where
     name = idName v
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 7e6406f..1b24684 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -711,6 +711,10 @@ tcIfaceExpr (IfaceLcl name)
   = tcIfaceLclId name 	`thenM` \ id ->
     returnM (Var id)
 
+tcIfaceExpr (IfaceTick modName tickNo)
+  = tcIfaceTick modName tickNo	`thenM` \ id ->
+    returnM (Var id)
+
 tcIfaceExpr (IfaceExt gbl)
   = tcIfaceExtId gbl 	`thenM` \ id ->
     returnM (Var id)
-- 
1.7.10.4