The breakpoint primitive

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

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4a5521c..554149c 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -9,15 +9,7 @@ Desugaring exporessions.
 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
 
 #include "HsVersions.h"
-#if defined(GHCI) && defined(BREAKPOINT)
-import Foreign.StablePtr
-import GHC.Exts
-import IOEnv
-import PrelNames
-import TysWiredIn
-import TypeRep
-import TyCon
-#endif
+
 
 import Match
 import MatchLit
@@ -29,8 +21,12 @@ import DsArrows
 import DsMonad
 
 #ifdef GHCI
+import PrelNames
+import DsBreakpoint
        -- Template Haskell stuff iff bootstrapped
 import DsMeta
+#else
+import DsBreakpoint
 #endif
 
 import HsSyn
@@ -111,11 +107,12 @@ ds_val_bind (NonRecursive, hsbinds) body
        --       below.  Then pattern-match would fail.  Urk.)
     putSrcSpanDs loc   $
     case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }
+      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
        -> matchWrapper (FunRhs (idName fun)) matches           `thenDs` \ (args, rhs) ->
           ASSERT( null args )  -- Functions aren't lifted
           ASSERT( isIdHsWrapper co_fn )
-          returnDs (bindNonRec fun rhs body_w_exports)
+           mkOptTickBox tick rhs                               `thenDs` \ rhs' ->
+          returnDs (bindNonRec fun rhs' body_w_exports)
 
       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
        ->      -- let C x# y# = rhs in body
@@ -178,6 +175,7 @@ scrungleMatch var scrut body
                    | x == var = Case scrut bndr ty alts
     scrungle (Let binds body)  = Let binds (scrungle body)
     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
+
 \end{code}     
 
 %************************************************************************
@@ -188,10 +186,21 @@ scrungleMatch var scrut body
 
 \begin{code}
 dsLExpr :: LHsExpr Id -> DsM CoreExpr
+
+#if defined(GHCI)
+dsLExpr (L loc expr@(HsWrap w (HsVar v)))
+    | idName v `elem` [breakpointName, breakpointCondName, breakpointAutoName]
+    = do areBreakpointsEnabled <- breakpoints_enabled
+         if areBreakpointsEnabled
+           then do
+              L _ breakpointExpr <- mkBreakpointExpr loc v
+              dsLExpr (L loc $ HsWrap w breakpointExpr)
+           else putSrcSpanDs loc $ dsExpr expr
+#endif
+
 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
-
 dsExpr (HsPar e)             = dsLExpr e
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 dsExpr (HsVar var)                   = returnDs (Var var)
@@ -209,37 +218,6 @@ dsExpr expr@(HsLam a_Match)
   = matchWrapper LambdaExpr a_Match    `thenDs` \ (binders, matching_code) ->
     returnDs (mkLams binders matching_code)
 
-#if defined(GHCI) && defined(BREAKPOINT)
-dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsWrap _ fun)) (L loc arg))) _)
-    | HsVar funId <- fun
-    , idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
-    , ids <- filter (isValidType . idType) (extractIds arg)
-    = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
-         stablePtr <- ioToIOEnv $ newStablePtr ids
-         -- Yes, I know... I'm gonna burn in hell.
-         let Ptr addr# = castStablePtrToPtr stablePtr
-         funCore <- dsLExpr realFun
-         argCore <- dsLExpr (L loc (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))))
-         hvalCore <- dsLExpr (L loc (extractHVals ids))
-         return ((funCore `App` argCore) `App` hvalCore)
-    where extractIds :: HsExpr Id -> [Id]
-          extractIds (HsApp fn arg)
-              | HsVar argId <- unLoc arg
-              = argId:extractIds (unLoc fn)
-              | HsWrap co_fn arg' <- unLoc arg
-              , HsVar argId <- arg'            -- SLPJ: not sure what is going on here
-              = error (showSDoc (ppr co_fn)) -- argId:extractIds (unLoc fn)
-          extractIds x = []
-          extractHVals ids = ExplicitList unitTy (map (L loc . HsVar) ids)
-          -- checks for tyvars and unlifted kinds.
-          isValidType (TyVarTy _) = False
-          isValidType (FunTy a b) = isValidType a && isValidType b
-          isValidType (NoteTy _ t) = isValidType t
-          isValidType (AppTy a b) = isValidType a && isValidType b
-          isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts
-          isValidType _ = True
-#endif
-
 dsExpr expr@(HsApp fun arg)      
   = dsLExpr fun                `thenDs` \ core_fun ->
     dsLExpr arg                `thenDs` \ core_arg ->
@@ -570,6 +548,26 @@ dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 \end{code}
 
+Hpc Support 
+
+\begin{code}
+dsExpr (HsTick ix e) = do
+  e' <- dsLExpr e
+  mkTickBox ix e'
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+dsExpr (HsBinTick ixT ixF e) = do
+  e2 <- dsLExpr e
+  do { ASSERT(exprType e2 `coreEqType` boolTy)
+       mkBinaryTickBox ixT ixF e2
+     }
+\end{code}
 
 \begin{code}