Commit fcf37c94 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-01-06 15:30:14 by simonpj]

--------------------------------------------------------------
	Several small but tiresome things shown up by Template Haskell
	--------------------------------------------------------------

1. Make the 'knot' in TcRnDriver much smaller; in fact move it to
   TcIfaceSig.tcInterfaceSigs.  Reasons
	a) much tidier
	b) avoids a loop in Template Haskell, when we try to run
	   an expression during type checking (when the knot is
	   not fully tied)

   See comments in TcIfaceSig

2. Stop typechecking if tcGroup fails.  Reason: otherwise tcLookup can
   fail in the next group.

3. Catch linking errors more gracefully when running a splice (in TcSplice)
parent 97ee3b24
......@@ -22,8 +22,7 @@ module TcEnv(
tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocalIds, tcLookup_maybe,
tcLookupId, tcLookupIdLvl,
getLclEnvElts, getInLocalScope,
findGlobals,
lclEnvElts, getInLocalScope, findGlobals,
-- Instance environment
tcExtendLocalInstEnv, tcExtendInstEnv,
......@@ -355,9 +354,8 @@ tcLookupLocalIds ns
Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
getLclEnvElts :: TcM [TcTyThing]
getLclEnvElts = getLclEnv `thenM` \ env ->
return (nameEnvElts (tcl_env env))
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
getInLocalScope :: TcM (Name -> Bool)
-- Ids only
......@@ -443,8 +441,8 @@ findGlobals :: TcTyVarSet
-> TcM (TidyEnv, [SDoc])
findGlobals tvs tidy_env
= getLclEnvElts `thenM` \ lcl_env ->
go tidy_env [] lcl_env
= getLclEnv `thenM` \ lcl_env ->
go tidy_env [] (lclEnvElts lcl_env)
where
go tidy_env acc [] = returnM (tidy_env, acc)
go tidy_env acc (thing : things)
......
......@@ -798,12 +798,15 @@ tcId name -- Look up the Id and instantiate its type
Brack use_lvl ps_var lie_var
| use_lvl > bind_lvl && not (isExternalName name)
-> -- E.g. \x -> [| h x |]
-- We must behave as if the reference to x was
-- h $(lift x)
-- We use 'x' itself as the splice proxy, used by
-- the desugarer to stitch it all back together
-- NB: isExernalName is true of top level things,
-- and false of nested bindings
-- We must behave as if the reference to x was
-- h $(lift x)
-- We use 'x' itself as the splice proxy, used by
-- the desugarer to stitch it all back together.
-- If 'x' occurs many times we may get many identical
-- bindings of the same splice proxy, but that doesn't
-- matter, although it's a mite untidy.
-- NB: isExernalName is true of top level things,
-- and false of nested bindings
let
id_ty = idType id
......
......@@ -55,15 +55,36 @@ As always, we do not have to worry about user-pragmas in interface
signatures.
\begin{code}
tcInterfaceSigs :: RecTcGblEnv -- Envt to use when checking unfoldings
-> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM TcGblEnv
tcInterfaceSigs unf_env decls
= sequenceM [ do_one name ty id_infos src_loc
| IfaceSig {tcdName = name, tcdType = ty,
tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
tcInterfaceSigs decls = fixM (tc_interface_sigs decls)
-- We tie a knot so that the Ids read out of interfaces are in scope
-- when we read their pragmas.
-- What we rely on is that pragmas are typechecked lazily; if
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
--
-- We used to have a much bigger loop (in TcRnDriver), so that the
-- interface pragmas could mention variables bound in this module
-- (by mutual recn), but
-- (a) the knot is tiresomely big, and
-- (b) it black-holes when we have Template Haskell
--
-- For (b) consider: f = $(...h....)
-- where h is imported, and calls f via an hi-boot file.
-- This is bad! But it is not seen as a staging error, because h
-- is indeed imported. We don't want the type-checker to black-hole
-- when simplifying and compiling the splice!
--
-- Simple solution: discard any unfolding that mentions a variable
-- bound in this module (and hence not yet processed).
-- The discarding happens when forkM finds a type error.
tc_interface_sigs decls unf_env
= sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids ->
tcExtendGlobalValEnv sig_ids getGblEnv
-- Return the extended environment
where
in_scope_vars = typeEnvIds (tcg_type_env unf_env)
-- When we have hi-boot files, an unfolding might refer to
......@@ -71,12 +92,13 @@ tcInterfaceSigs unf_env decls
-- suitable in-scope set. This thunk will only be poked
-- if -dcore-lint is on.
do_one name ty id_infos src_loc
= addSrcLoc src_loc $
do_one IfaceSig {tcdName = name, tcdType = ty,
tcdIdInfo = id_infos, tcdLoc = src_loc}
= addSrcLoc src_loc $
addErrCtxt (ifaceSigCtxt name) $
tcIfaceType ty `thenM` \ sigma_ty ->
tcIfaceType ty `thenM` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
sigma_ty id_infos `thenM` \ id_info ->
sigma_ty id_infos `thenM` \ id_info ->
returnM (mkVanillaGlobal name sigma_ty id_info)
\end{code}
......
......@@ -261,8 +261,11 @@ tcRnStmt :: HscEnv -> PersistentCompilerState
-> RdrNameStmt
-> IO (PersistentCompilerState,
Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
-- The returned [Id] is the same as the input except for
-- The returned [Name] is the same as the input except for
-- ExprStmt, in which case the returned [Name] is [itName]
--
-- The returned TypecheckedHsExpr is of type IO [ () ],
-- a list of the bound values, coerced to ().
tcRnStmt hsc_env pcs ictxt rdr_stmt
= initTc hsc_env pcs iNTERACTIVE $
......@@ -602,16 +605,20 @@ tcRnSrcDecls ds
-- Type check the decls up to, but not including, the first splice
(tcg_env, src_fvs1) <- tcRnGroup first_group ;
-- If there is no splice, we're done
case group_tail of
Nothing -> return (tcg_env, src_fvs1)
Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
setGblEnv tcg_env $ do {
-- Bale out if errors; for example, error recovery when checking
-- the RHS of 'main' can mean that 'main' is not in the envt for
-- the subsequent checkMain test
failIfErrsM ;
-- If there is no splice, we're done
case group_tail of {
Nothing -> return (tcg_env, src_fvs1) ;
Just (SpliceDecl splice_expr splice_loc, rest_ds) ->
#ifndef GHCI
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
setGblEnv tcg_env $ do {
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, fvs) <- initRn SourceMode $
addSrcLoc splice_loc $
......@@ -626,9 +633,9 @@ tcRnSrcDecls ds
(tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
return (tcg_env, src_fvs1 `plusFV` src_fvs2)
}
}}
#endif /* GHCI */
}}}
}}
\end{code}
......@@ -695,15 +702,9 @@ rnTopSrcDecls group
------------------------------------------------
tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
tcTopSrcDecls rn_decls
= fixM (\ unf_env -> do {
-- Loop back the final environment, including the fully zonked
-- versions of bindings from this module. In the presence of mutual
-- recursion, interface type signatures may mention variables defined
-- in this module, which is why the knot is so big
-- Do the main work
= do { -- Do the main work
((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE (
tc_src_decls unf_env rn_decls
tc_src_decls rn_decls
) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
......@@ -717,24 +718,25 @@ tcTopSrcDecls rn_decls
setLclTypeEnv lcl_env $
tcSimplifyTop lie ;
-- The setGblEnv exposes the instances to tcSimplifyTop
-- The steLclTypeEnv exposes the local Ids, so that
-- The setLclTypeEnv exposes the local Ids, so that
-- we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
(ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
rules fords ;
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
rules fords ;
let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env)
bind_ids,
tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
tcg_rules = tcg_rules tcg_env ++ rules',
tcg_fords = tcg_fords tcg_env ++ fords' } } ;
return tcg_env'
})
}
tc_src_decls unf_env
tc_src_decls
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
......@@ -743,7 +745,7 @@ tc_src_decls unf_env
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
traceTc (text "Tc2") ;
tcg_env <- tcTyClDecls unf_env tycl_decls ;
tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
......@@ -808,8 +810,7 @@ tc_src_decls unf_env
\end{code}
\begin{code}
tcTyClDecls :: RecTcGblEnv
-> [RenamedTyClDecl]
tcTyClDecls :: [RenamedTyClDecl]
-> TcM TcGblEnv
-- tcTyClDecls deals with
......@@ -820,11 +821,7 @@ tcTyClDecls :: RecTcGblEnv
-- persistent compiler state to reflect the things imported from
-- other modules
tcTyClDecls unf_env tycl_decls
-- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
-- which is done lazily [ie failure just drops the pragma
-- without having any global-failure effect].
tcTyClDecls tycl_decls
= checkNoErrs $
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
......@@ -832,18 +829,12 @@ tcTyClDecls unf_env tycl_decls
traceTc (text "TyCl1") `thenM_`
tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
tcExtendGlobalEnv tycl_things $
-- Interface type signatures
-- We tie a knot so that the Ids read out of interfaces are in scope
-- when we read their pragmas.
-- What we rely on is that pragmas are typechecked lazily; if
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
traceTc (text "TyCl2") `thenM_`
tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
getGblEnv -- Return the TcLocals environment
traceTc (text "TyCl2") `thenM_`
tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
-- Returns the extended environment
returnM tcg_env
\end{code}
......@@ -943,7 +934,7 @@ typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_ruleds = rule_decls })
= do { -- Typecheck the type, class, and interface-sig decls
tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- Typecheck the instance decls, and rules
......
......@@ -19,7 +19,7 @@ module TcSimplify (
#include "HsVersions.h"
import {-# SOURCE #-} TcUnify( unifyTauTy )
import TcEnv -- temp
import TcEnv -- temp
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
......@@ -1609,8 +1609,8 @@ It's OK: the final zonking stage should zap y to (), which is fine.
\begin{code}
tcSimplifyTop :: [Inst] -> TcM TcDictBinds
tcSimplifyTop wanteds
= getLclEnvElts `thenM` \ lcl_env ->
traceTc (text "tcSimplifyTop" <+> ppr lcl_env) `thenM_`
= getLclEnv `thenM` \ lcl_env ->
traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_`
simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
ASSERT( null frees )
......
......@@ -35,6 +35,7 @@ import TysWiredIn ( mkListTy )
import DsMeta ( exprTyConName, declTyConName, decTyConName, qTyConName )
import ErrUtils (Message)
import Outputable
import Panic ( showException )
import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy
import Monad (liftM)
\end{code}
......@@ -128,17 +129,21 @@ tcSpliceExpr name expr res_ty
-- inner escape before dealing with the outer one
tcTopSplice expr res_ty
= tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
setStage topSpliceStage (
getLIE (tcMonoExpr expr meta_exp_ty)
) `thenM` \ (expr', lie) ->
= checkNoErrs (
-- checkNoErrs: must not try to run the thing
-- if the type checker fails!
tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
setStage topSpliceStage (
getLIE (tcMonoExpr expr meta_exp_ty)
) `thenM` \ (expr', lie) ->
-- Solve the constraints
tcSimplifyTop lie `thenM` \ const_binds ->
let
q_expr = mkHsLet const_binds expr'
in
zonkTopExpr q_expr `thenM` \ zonked_q_expr ->
tcSimplifyTop lie `thenM` \ const_binds ->
-- Wrap the bindings around it and zonk
zonkTopExpr (mkHsLet const_binds expr')
) `thenM` \ zonked_q_expr ->
-- Run the expression
traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
......@@ -216,9 +221,6 @@ runMetaD :: TypecheckedHsExpr -- Of type Q [Dec]
-> TcM [Meta.Dec] -- Of type [Dec]
runMetaD e = runMeta e
tcRunQ :: Meta.Q a -> TcM a
tcRunQ thing = ioToTcRn (Meta.runQ thing)
runMeta :: TypecheckedHsExpr -- Of type X
-> TcM t -- Of type t
runMeta expr
......@@ -238,16 +240,20 @@ runMeta expr
type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
in
ioToTcRn (HscMain.compileExpr
hsc_env pcs this_mod
rdr_env type_env expr) `thenM` \ hval ->
tryM (tcRunQ (unsafeCoerce# hval)) `thenM` \ either_tval ->
-- Wrap the compile-and-run in an exception-catcher
-- Compiling might fail if linking fails
-- Running might fail if it throws an exception
tryM (ioToTcRn (do
hval <- HscMain.compileExpr
hsc_env pcs this_mod
rdr_env type_env expr
Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it
)) `thenM` \ either_tval ->
case either_tval of
Left exn -> failWithTc (vcat [text "Exception when running compile-time code:",
Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:",
nest 4 (vcat [text "Code:" <+> ppr expr,
text ("Exn: " ++ show exn)])])
text ("Exn: " ++ Panic.showException exn)])])
Right v -> returnM v
\end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment