Re-working of the breakpoint support

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

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 455db04..3c56567 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -69,6 +69,8 @@ import SrcLoc
 import Util
 import ListSetOps
 import FastString
+import StaticFlags
+
 import Data.Char
 
 infixl 4 `mkDsApp`, `mkDsApps`
@@ -942,15 +944,22 @@ mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
 mkTickBox ix e = do
        uq <- newUnique         
        mod <- getModuleDs
-       let tick = mkTickBoxOpId uq mod ix
+       let tick | opt_Hpc   = mkTickBoxOpId uq mod ix
+                | otherwise = mkBreakPointOpId 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)]
+       scrut <- 
+          if opt_Hpc 
+            then return (Var tick)
+            else do
+              locals <- getLocalBindsDs
+              let tickVar = Var tick
+              let tickType = mkFunTys (map idType locals) realWorldStatePrimTy 
+              let scrutApTy = App tickVar (Type tickType)
+              return (mkApps scrutApTy (map Var locals) :: Expr Id)
+       return $ Case scrut var ty [(DEFAULT,[],e)]
   where
      ty = exprType e
 
@@ -966,4 +975,4 @@ mkBinaryTickBox ixT ixF e = do
                        [ (DataAlt falseDataCon, [], falseBox)
                        , (DataAlt trueDataCon,  [], trueBox)
                        ]
-\end{code}
\ No newline at end of file
+\end{code}