Temporary fix for a nasty black hole
The problem is that the type checker has a big knot for "unf_env".
This means that we can't look at unfoldings inside the loop, which
is fair enough. But setting an unfolding in the IdInfo is strict
in the unfolding, so we can't look at the IdInfo either.
But isLocalId looks at the IdInfo, and it was being used in an
assert in TcHsSyn, and in setting the in_scope_vars in TcIfaceSig.
I think the right solution is to take the "flavour" out of IdInfo,
and put it into VarDetails, but I've done a quick fix for now.
(Remove the assert, and use a different way in TcIfaceSig.)
rule_base = extendRuleBaseList imp_rule_base orphan_rules
final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
-- The last step black-lists the free vars of local rules too
rule_base = extendRuleBaseList imp_rule_base orphan_rules
final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
-- The last step black-lists the free vars of local rules too
; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
let
new_id = case maybe_id' of
Just (AnId id') -> id'
let
new_id = case maybe_id' of
Just (AnId id') -> id'
- other -> WARN( isLocalId id, ppr id ) id
+ other -> id -- WARN( isLocalId id, ppr id ) id
+ -- Oops: the warning can give a black hole
+ -- because it looks at the idinfo
in
returnNF_Tc new_id
\end{code}
in
returnNF_Tc new_id
\end{code}
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkId, mkVanillaId, isLocalId, isDataConWrapId_maybe )
+import Id ( Id, mkId, mkVanillaId, idName, isDataConWrapId_maybe )
+import Module ( Module )
import MkId ( mkCCallOpId )
import IdInfo
import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
import MkId ( mkCCallOpId )
import IdInfo
import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys )
import Type ( mkTyVarTys, splitAlgTyConApp_maybe )
import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
+import Name ( Name, nameIsLocalOrFrom )
import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Outputable
import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Outputable
\begin{code}
tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
\begin{code}
tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
+ -> Module -- This module
-> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
-> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
-tcInterfaceSigs unf_env decls
+tcInterfaceSigs unf_env mod decls
= listTc [ do_one name ty id_infos src_loc
| IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
where
= listTc [ do_one name ty id_infos src_loc
| IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
where
- in_scope_vars = filter isLocalId (tcEnvIds unf_env)
+ in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
+ -- Oops: using isLocalId instead can give a black hole
+ -- because it looks at the idinfo
+
-- When we have hi-boot files, an unfolding might refer to
-- something defined in this module, so we must build a
-- suitable in-scope set. This thunk will only be poked
-- When we have hi-boot files, an unfolding might refer to
-- something defined in this module, so we must build a
-- suitable in-scope set. This thunk will only be poked
tcVar name
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
case maybe_id of {
tcVar name
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
case maybe_id of {
- Just (AnId id) -> returnTc id;
+ Just (AnId id) -> returnTc id ;
Nothing -> failWithTc (noDecl name)
}
Nothing -> failWithTc (noDecl name)
}
TyThing(..), implicitTyThingIds,
mkTypeEnv
)
TyThing(..), implicitTyThingIds,
mkTypeEnv
)
+import Rules ( ruleBaseIds )
+import VarSet
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
traceTc (text "Tc3") `thenNF_Tc_`
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
traceTc (text "Tc3") `thenNF_Tc_`
- tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
+ tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
tcExtendGlobalValEnv sig_ids $
tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
-- No zonking necessary!
tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
-- No zonking necessary!
-tcIfaceRule (IfaceRule name vars fun args rhs src_loc)
+tcIfaceRule rule@(IfaceRule name vars fun args rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
tcVar fun `thenTc` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
mapTc tcCoreExpr args `thenTc` \ args' ->
tcCoreExpr rhs `thenTc` \ rhs' ->
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
tcVar fun `thenTc` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
mapTc tcCoreExpr args `thenTc` \ args' ->
tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (IfaceRuleOut fun' (Rule name vars' args' rhs'))
-
+ let
+ new_rule :: TypecheckedRuleDecl
+ new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs')
+ in
+ returnTc new_rule
tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
tcSourceRules decls
tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
tcSourceRules decls