From eca538c8c62951d6f140c99c88a97ef2b0a0497d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Dec 2006 22:25:40 +0000 Subject: [PATCH] Capturing and keeping track of local bindins in the desugarer Used in the desugaring of the breakpoint primitive --- compiler/deSugar/DsExpr.lhs | 18 ++++++++++++----- compiler/deSugar/DsGRHSs.lhs | 23 ++++++++++++++------- compiler/deSugar/DsMonad.lhs | 46 +++++++++++++++++++++++++++--------------- 3 files changed, 59 insertions(+), 28 deletions(-) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 8c75dc9..e90a556 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -290,8 +290,11 @@ dsExpr (HsCase discrim matches) 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) - = dsAndThenMaybeInsertBreakpoint 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) @@ -602,11 +605,16 @@ dsDo stmts body result_ty ; 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) @@ -666,7 +674,7 @@ dsMDo tbl stmts body result_ty ; 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) diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 12e0f0b..8f24239 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -14,6 +14,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn +import HsUtils import CoreSyn import Var import Type @@ -27,6 +28,7 @@ import TysWiredIn import PrelNames import Name import SrcLoc + \end{code} @dsGuarded@ is used for both @case@ expressions and pattern bindings. @@ -56,18 +58,23 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext -> GRHSs Id -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult - -dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty - = mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results -> +dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = + bindLocalsDs (bindsBinders ++ patsBinders) $ + mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results -> let match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 + match_result2 = adjustMatchResultDs + (\e -> bindLocalsDs patsBinders $ dsLocalBinds binds e) + match_result1 -- NB: nested dsLet inside matchResult in returnDs match_result2 + where bindsBinders = map unLoc (collectLocalBinders binds) + patsBinders = collectPatsBinders (map (L undefined) pats) dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs)) - = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty + = do rhs' <- maybeInsertBreakpoint rhs rhs_ty + matchGuards (map unLoc guards) hs_ctx rhs' rhs_ty \end{code} @@ -110,7 +117,8 @@ matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty returnDs (mkGuardedMatchResult pred_expr match_result) matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty - = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result -> + = bindLocalsDs (map unLoc $ collectLocalBinders binds) $ + matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result -> returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result -- Reason: dsLet takes the body expression as its argument @@ -118,7 +126,8 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty -- body expression in hand matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty - = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result -> + = bindLocalsDs (collectPatBinders pat) $ + matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result -> dsLExpr bind_rhs `thenDs` \ core_rhs -> matchSinglePat core_rhs ctx pat rhs_ty match_result \end{code} diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 8d11931..d3dd0e1 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -23,7 +23,7 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - getBkptSitesDs, + bindLocalsDs, getLocalBindsDs, getBkptSitesDs, -- Warnings DsWarning, warnDs, failWithDs, @@ -143,7 +143,8 @@ data DsGblEnv = DsGblEnv { data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings - ds_loc :: SrcSpan -- to put in pattern-matching error msgs + ds_loc :: SrcSpan, -- to put in pattern-matching error msgs + ds_locals :: OccEnv Id -- For locals in breakpoints } -- Inside [| |] brackets, the desugarer looks @@ -166,7 +167,7 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) - ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var + ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ tryM thing_inside -- Catch exceptions (= errors during desugaring) @@ -194,21 +195,26 @@ initDsTc thing_inside ; msg_var <- getErrsVar ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env - ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside } + ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var + ; setEnvs ds_envs thing_inside } -mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv - -> IORef Messages -> (DsGblEnv, DsLclEnv) +mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) mkDsEnvs mod rdr_env type_env msg_var - = (gbl_env, lcl_env) - where - if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } - if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) - gbl_env = DsGblEnv { ds_mod = mod, - ds_if_env = (if_genv, if_lenv), - ds_unqual = mkPrintUnqualified rdr_env, - ds_msgs = msg_var } - lcl_env = DsLclEnv { ds_meta = emptyNameEnv, - ds_loc = noSrcSpan } + = do + sites_var <- newIORef [] + let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } + if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) + gbl_env = DsGblEnv { ds_mod = mod, + ds_if_env = (if_genv, if_lenv), + ds_unqual = mkPrintUnqualified rdr_env, + ds_msgs = msg_var, + ds_bkptSites = sites_var} + lcl_env = DsLclEnv { ds_meta = emptyNameEnv, + ds_loc = noSrcSpan, + ds_locals = emptyOccEnv } + + return (gbl_env, lcl_env) + \end{code} %************************************************************************ @@ -328,6 +334,14 @@ dsExtendMetaEnv menv thing_inside \end{code} \begin{code} +getLocalBindsDs :: DsM [Id] +getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) } + +bindLocalsDs :: [Id] -> DsM a -> DsM a +bindLocalsDs new_ids enclosed_scope = + updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids}) + enclosed_scope + where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ] getBkptSitesDs :: DsM (IORef SiteMap) getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) } -- 1.7.10.4