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
import DsMonad
#ifdef GHCI
+import PrelNames
+import DsBreakpoint
-- Template Haskell stuff iff bootstrapped
import DsMeta
+#else
+import DsBreakpoint
#endif
import HsSyn
| 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}
%************************************************************************
\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)
= 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 ->
matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
returnDs (scrungleMatch discrim_var core_discrim matching_code)
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+-- This is to avoid silliness in breakpoints
dsExpr (HsLet binds body)
- = dsLExpr body `thenDs` \ body' ->
+ = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $
+ dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
dsDo stmts body result_ty
= go (map unLoc stmts)
where
- go [] = dsLExpr body
+ go [] = dsAndThenMaybeInsertBreakpoint body
go (ExprStmt rhs then_expr _ : stmts)
- = do { rhs2 <- dsLExpr rhs
+ = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
; then_expr2 <- dsExpr then_expr
; rest <- go stmts
; returnDs (mkApps then_expr2 [rhs2, rest]) }
go (LetStmt binds : stmts)
- = do { rest <- go stmts
+ = do { rest <- bindLocalsDs (map unLoc$ collectLocalBinders binds) $
+ go stmts
; dsLocalBinds binds rest }
-
+
+ -- Notice how due to the placement of bindLocals, binders in this stmt
+ -- are available in posterior stmts but Not in this one rhs.
+ -- This is to avoid silliness in breakpoints
go (BindStmt pat rhs bind_op fail_op : stmts)
- = do { body <- go stmts
+ =
+ do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
result_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
- ; rhs' <- dsLExpr rhs
+ ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
; bind_op' <- dsExpr bind_op
; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
- = do { rhs2 <- dsLExpr rhs
+ = do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
; rest <- go stmts
; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
go (BindStmt pat rhs _ _ : stmts)
- = do { body <- go stmts
+ = do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
; match_code <- extractMatchResult match fail_expr
- ; rhs' <- dsLExpr rhs
+ ; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
projects / ghc-hetmet.git / blobdiff