Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
eca538c8
Commit
eca538c8
authored
Dec 10, 2006
by
mnislaih
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Capturing and keeping track of local bindins in the desugarer
Used in the desugaring of the breakpoint primitive
parent
1df34b32
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
59 additions
and
28 deletions
+59
-28
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsExpr.lhs
+13
-5
compiler/deSugar/DsGRHSs.lhs
compiler/deSugar/DsGRHSs.lhs
+16
-7
compiler/deSugar/DsMonad.lhs
compiler/deSugar/DsMonad.lhs
+30
-16
No files found.
compiler/deSugar/DsExpr.lhs
View file @
eca538c8
...
...
@@ -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)
...
...
compiler/deSugar/DsGRHSs.lhs
View file @
eca538c8
...
...
@@ -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 b
inds)
rhs_ty
=
mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results ->
dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty =
bindLocalsDs (bindsBinders ++ patsB
ind
er
s)
$
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}
...
...
compiler/deSugar/DsMonad.lhs
View file @
eca538c8
...
...
@@ -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) }
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment