[project @ 2001-02-27 11:50:05 by simonpj]

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.)

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 5bf0fe8..bcfbbfa 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -217,7 +217,6 @@ prepareRules dflags pkg_rule_base hst us binds rules
              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

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index e7805cf..24782f7 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -167,7 +167,9 @@ zonkIdOcc 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}

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 6ec6b44..0a97ff4 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -25,14 +25,15 @@ import CoreUnfold
 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 Name            ( Name )
+import Name            ( Name, nameIsLocalOrFrom )
 import Demand          ( wwLazy )
 import ErrUtils                ( pprBagOfErrors )
 import Outputable      
@@ -49,15 +50,19 @@ signatures.
 
 \begin{code}
 tcInterfaceSigs :: RecTcEnv            -- Envt to use when checking unfoldings
+               -> Module               -- This module
                -> [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
-    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
@@ -171,7 +176,7 @@ tcVar :: Name -> TcM Id
 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)
     }
 

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 7987d4f..56f7e0d 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -69,6 +69,8 @@ import HscTypes               ( PersistentCompilerState(..), HomeSymbolTable,
                          TyThing(..), implicitTyThingIds, 
                          mkTypeEnv
                        )
+import Rules ( ruleBaseIds )
+import VarSet
 \end{code}
 
 
@@ -463,7 +465,7 @@ tcImports unf_env pcs hst get_fixity this_mod decls
     --   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               $
     
     

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index ca6dab6..69d462b 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -50,15 +50,18 @@ tcIfaceRules pkg_rule_base mod decls
 
 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' ->
-    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