TcIface.lhs 64.9 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3 4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Type checking of type signatures in interface files
7 8

\begin{code}
9 10
{-# LANGUAGE CPP #-}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
11 12 13
module TcIface (
        tcLookupImported_maybe,
        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
14
        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
15
        tcIfaceVectInfo, tcIfaceAnnotations,
16
        tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
Austin Seipp's avatar
Austin Seipp committed
17
        tcIfaceGlobal
18
 ) where
19

20 21
#include "HsVersions.h"

22
import TcTypeNats(typeNatCoAxiomRules)
23
import IfaceSyn
Simon Marlow's avatar
Simon Marlow committed
24 25 26
import LoadIface
import IfaceEnv
import BuildTyCl
27
import TcRnMonad
28
import TcType
Simon Marlow's avatar
Simon Marlow committed
29
import Type
30
import Coercion
Simon Marlow's avatar
Simon Marlow committed
31 32
import TypeRep
import HscTypes
33
import Annotations
Simon Marlow's avatar
Simon Marlow committed
34 35
import InstEnv
import FamInstEnv
36
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
37
import CoreUtils
38
import CoreUnfold
Simon Marlow's avatar
Simon Marlow committed
39
import CoreLint
40
import MkCore                       ( castBottomExpr )
Simon Marlow's avatar
Simon Marlow committed
41 42 43 44 45
import Id
import MkId
import IdInfo
import Class
import TyCon
46
import CoAxiom
Gergő Érdi's avatar
Gergő Érdi committed
47
import ConLike
Simon Marlow's avatar
Simon Marlow committed
48
import DataCon
49
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
50
import TysWiredIn
51
import TysPrim          ( superKindTyConName )
52
import BasicTypes       ( strongLoopBreaker )
53
import Literal
Simon Marlow's avatar
Simon Marlow committed
54
import qualified Var
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
55
import VarEnv
56
import VarSet
Simon Marlow's avatar
Simon Marlow committed
57
import Name
58
import NameEnv
59 60
import NameSet
import OccurAnal        ( occurAnalyseExpr )
61
import Demand
Simon Marlow's avatar
Simon Marlow committed
62
import Module
63
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
64
import UniqSupply
Simon Peyton Jones's avatar
Simon Peyton Jones committed
65
import Outputable
Simon Marlow's avatar
Simon Marlow committed
66 67 68 69
import ErrUtils
import Maybes
import SrcLoc
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
70
import Util
71
import FastString
Simon Marlow's avatar
Simon Marlow committed
72

73
import Control.Monad
74
import qualified Data.Map as Map
75
import Data.Traversable ( traverse )
76 77 78 79
\end{code}

This module takes

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
80 81 82
        IfaceDecl -> TyThing
        IfaceType -> Type
        etc
83 84 85 86

An IfaceDecl is populated with RdrNames, and these are not renamed to
Names before typechecking, because there should be no scope errors etc.

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
87
        -- For (b) consider: f = \$(...h....)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
88
        -- where h is imported, and calls f via an hi-boot file.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
89
        -- This is bad!  But it is not seen as a staging error, because h
Simon Peyton Jones's avatar
Simon Peyton Jones committed
90
        -- is indeed imported.  We don't want the type-checker to black-hole
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
91 92 93 94 95
        -- 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.
96 97

%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
98 99 100 101
%*                                                                      *
%*      tcImportDecl is the key function for "faulting in"              *
%*      imported things
%*                                                                      *
102 103 104 105
%************************************************************************

The main idea is this.  We are chugging along type-checking source code, and
find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
Simon Peyton Jones's avatar
Simon Peyton Jones committed
106
it in the EPS type envt.  So it
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
107 108 109 110
        1 loads GHC.Base.hi
        2 gets the decl for GHC.Base.map
        3 typechecks it via tcIfaceDecl
        4 and adds it to the type env in the EPS
111

Simon Peyton Jones's avatar
Simon Peyton Jones committed
112 113
Note that DURING STEP 4, we may find that map's type mentions a type
constructor that also
114 115 116

Notice that for imported things we read the current version from the EPS
mutable variable.  This is important in situations like
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
117
        ...$(e1)...$(e2)...
Simon Peyton Jones's avatar
Simon Peyton Jones committed
118
where the code that e1 expands to might import some defns that
119 120 121
also turn out to be needed by the code that e2 expands to.

\begin{code}
122 123 124 125 126
tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
tcLookupImported_maybe name
  = do  { hsc_env <- getTopEnv
        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
127
        ; case mb_thing of
128 129 130 131
            Just thing -> return (Succeeded thing)
            Nothing    -> tcImportDecl_maybe name }

tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
132
-- Entry point for *source-code* uses of importDecl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
133
tcImportDecl_maybe name
134
  | Just thing <- wiredInNameTyThing_maybe name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
135 136 137
  = do  { when (needWiredInHomeIface thing)
               (initIfaceTcRn (loadWiredInHomeIface name))
                -- See Note [Loading instances for wired-in things]
138
        ; return (Succeeded thing) }
139
  | otherwise
140
  = initIfaceTcRn (importDecl name)
141

142
importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
143
-- Get the TyThing for this Name from an interface file
144 145 146
-- It's not a wired-in thing -- the caller caught that
importDecl name
  = ASSERT( not (isWiredInName name) )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
147 148 149
    do  { traceIf nd_doc

        -- Load the interface, which should populate the PTE
Simon Peyton Jones's avatar
Simon Peyton Jones committed
150
        ; mb_iface <- ASSERT2( isExternalName name, ppr name )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
151 152 153 154 155 156
                      loadInterface nd_doc (nameModule name) ImportBySystem
        ; case mb_iface of {
                Failed err_msg  -> return (Failed err_msg) ;
                Succeeded _ -> do

        -- Now look it up again; this time we should find it
Simon Peyton Jones's avatar
Simon Peyton Jones committed
157
        { eps <- getEps
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
158 159 160
        ; case lookupTypeEnv (eps_PTE eps) name of
            Just thing -> return (Succeeded thing)
            Nothing    -> return (Failed not_found_msg)
161
    }}}
162
  where
Ian Lynagh's avatar
Ian Lynagh committed
163 164
    nd_doc = ptext (sLit "Need decl for") <+> ppr name
    not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
165 166 167
                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
                       2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
                                ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
168 169
\end{code}

170
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
171
%*                                                                      *
172
           Checks for wired-in things
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
173
%*                                                                      *
174 175 176 177 178
%************************************************************************

Note [Loading instances for wired-in things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to make sure that we have at least *read* the interface files
Simon Peyton Jones's avatar
Simon Peyton Jones committed
179
for any module with an instance decl or RULE that we might want.
180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208

* If the instance decl is an orphan, we have a whole separate mechanism
  (loadOprhanModules)

* If the instance decl not an orphan, then the act of looking at the
  TyCon or Class will force in the defining module for the
  TyCon/Class, and hence the instance decl

* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;
  but we must make sure we read its interface in case it has instances or
  rules.  That is what LoadIface.loadWiredInHomeInterface does.  It's called
  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}

* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There
  are some wired-in Ids, but we don't want to load their interfaces. For
  example, Control.Exception.Base.recSelError is wired in, but that module
  is compiled late in the base library, and we don't want to force it to
  load before it's been compiled!

All of this is done by the type checker. The renamer plays no role.
(It used to, but no longer.)


\begin{code}
checkWiredInTyCon :: TyCon -> TcM ()
-- Ensure that the home module of the TyCon (and hence its instances)
-- are loaded. See Note [Loading instances for wired-in things]
-- It might not be a wired-in tycon (see the calls in TcUnify),
-- in which case this is a no-op.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
209 210
checkWiredInTyCon tc
  | not (isWiredInName tc_name)
211 212
  = return ()
  | otherwise
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
213
  = do  { mod <- getModule
Simon Peyton Jones's avatar
Simon Peyton Jones committed
214
        ; ASSERT( isExternalName tc_name )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
215 216 217 218 219 220
          when (mod /= nameModule tc_name)
               (initIfaceTcRn (loadWiredInHomeIface tc_name))
                -- Don't look for (non-existent) Float.hi when
                -- compiling Float.lhs, which mentions Float of course
                -- A bit yukky to call initIfaceTcRn here
        }
221 222 223 224 225 226 227 228 229
  where
    tc_name = tyConName tc

ifCheckWiredInThing :: TyThing -> IfL ()
-- Even though we are in an interface file, we want to make
-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
-- Ditto want to ensure that RULES are loaded too
-- See Note [Loading instances for wired-in things]
ifCheckWiredInThing thing
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
230 231 232 233 234 235
  = do  { mod <- getIfModule
                -- Check whether we are typechecking the interface for this
                -- very module.  E.g when compiling the base library in --make mode
                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
                -- the HPT, so without the test we'll demand-load it into the PIT!
                -- C.f. the same test in checkWiredInTyCon above
236
        ; let name = getName thing
Simon Peyton Jones's avatar
Simon Peyton Jones committed
237
        ; ASSERT2( isExternalName name, ppr name )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
238 239
          when (needWiredInHomeIface thing && mod /= nameModule name)
               (loadWiredInHomeIface name) }
240 241 242 243 244 245 246

needWiredInHomeIface :: TyThing -> Bool
-- Only for TyCons; see Note [Loading instances for wired-in things]
needWiredInHomeIface (ATyCon {}) = True
needWiredInHomeIface _           = False
\end{code}

247
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
248 249 250
%*                                                                      *
                Type-checking a complete interface
%*                                                                      *
251 252
%************************************************************************

253 254 255 256 257 258 259 260
Suppose we discover we don't need to recompile.  Then we must type
check the old interface file.  This is a bit different to the
incremental type checking we do as we suck in interface files.  Instead
we do things similarly as when we are typechecking source decls: we
bring into scope the type envt for the interface all at once, using a
knot.  Remember, the decls aren't necessarily in dependency order --
and even if they were, the type decls might be mutually recursive.

261
\begin{code}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
262 263
typecheckIface :: ModIface      -- Get the decls from here
               -> TcRnIf gbl lcl ModDetails
264 265
typecheckIface iface
  = initIfaceTc iface $ \ tc_env_var -> do
Simon Peyton Jones's avatar
Simon Peyton Jones committed
266
        -- The tc_env_var is freshly allocated, private to
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
267 268 269 270
        -- type-checking this particular interface
        {       -- Get the right set of decls and rules.  If we are compiling without -O
                -- we discard pragmas before typechecking, so that we don't "see"
                -- information that we shouldn't.  From a versioning point of view
Simon Peyton Jones's avatar
Simon Peyton Jones committed
271
                -- It's not actually *wrong* to do so, but in fact GHCi is unable
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
272
                -- to handle unboxed tuples, so it must not see unfoldings.
ian@well-typed.com's avatar
ian@well-typed.com committed
273
          ignore_prags <- goptM Opt_IgnoreInterfacePragmas
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
274 275 276 277 278 279 280 281 282 283 284 285 286 287

                -- Typecheck the decls.  This is done lazily, so that the knot-tying
                -- within this single module work out right.  In the If monad there is
                -- no global envt for the current interface; instead, the knot is tied
                -- through the if_rec_types field of IfGblEnv
        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
        ; let type_env = mkNameEnv names_w_things
        ; writeMutVar tc_env_var type_env

                -- Now do those rules, instances and annotations
        ; insts     <- mapM tcIfaceInst (mi_insts iface)
        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
        ; anns      <- tcIfaceAnnotations (mi_anns iface)
288

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
289
                -- Vectorisation information
290
        ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
291

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
292 293 294 295 296 297 298 299 300 301 302
                -- Exports
        ; exports <- ifaceExportNames (mi_exports iface)

                -- Finished
        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
                         text "Type envt:" <+> ppr type_env])
        ; return $ ModDetails { md_types     = type_env
                              , md_insts     = insts
                              , md_fam_insts = fam_insts
                              , md_rules     = rules
                              , md_anns      = anns
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
303
                              , md_vect_info = vect_info
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
304 305
                              , md_exports   = exports
                              }
306
    }
307 308 309
\end{code}


310
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
311 312 313
%*                                                                      *
                Type and class declarations
%*                                                                      *
314 315 316
%************************************************************************

\begin{code}
317
tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
318 319 320
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the ModDetails, empty if no hi-boot iface
321
tcHiBootIface hsc_src mod
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
322
  | isHsBoot hsc_src            -- Already compiling a hs-boot file
323 324
  = return emptyModDetails
  | otherwise
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
325 326 327 328 329 330
  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)

        ; mode <- getGhcMode
        ; if not (isOneShot mode)
                -- In --make and interactive mode, if this module has an hs-boot file
                -- we'll have compiled it already, and it'll be in the HPT
Simon Peyton Jones's avatar
Simon Peyton Jones committed
331
                --
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
332 333
                -- We check wheher the interface is a *boot* interface.
                -- It can happen (when using GHC from Visual Studio) that we
Simon Peyton Jones's avatar
Simon Peyton Jones committed
334
                -- compile a module in TypecheckOnly mode, with a stable,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
335 336
                -- fully-populated HPT.  In that case the boot interface isn't there
                -- (it's been replaced by the mother module) so we can't check it.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
337
                -- And that's fine, because if M's ModInfo is in the HPT, then
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
338 339 340
                -- it's been compiled once, and we don't need to check the boot iface
          then do { hpt <- getHpt
                  ; case lookupUFM hpt (moduleName mod) of
Simon Peyton Jones's avatar
Simon Peyton Jones committed
341
                      Just info | mi_boot (hm_iface info)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
342 343 344 345
                                -> return (hm_details info)
                      _ -> return emptyModDetails }
          else do

Simon Peyton Jones's avatar
Simon Peyton Jones committed
346 347 348
        -- OK, so we're in one-shot mode.
        -- In that case, we're read all the direct imports by now,
        -- so eps_is_boot will record if any of our imports mention us by
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
349 350 351 352 353 354 355 356
        -- way of hi-boot file
        { eps <- getEps
        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
            Nothing -> return emptyModDetails ; -- The typical case

            Just (_, False) -> failWithTc moduleLoop ;
                -- Someone below us imported us!
                -- This is a loop with no hi-boot in the way
Simon Peyton Jones's avatar
Simon Peyton Jones committed
357

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
358
            Just (_mod, True) ->        -- There's a hi-boot interface below us
Simon Peyton Jones's avatar
Simon Peyton Jones committed
359 360

    do  { read_result <- findAndReadIface
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
361 362 363 364 365 366
                                need mod
                                True    -- Hi-boot file

        ; case read_result of
                Failed err               -> failWithTc (elaborate err)
                Succeeded (iface, _path) -> typecheckIface iface
367
    }}}}
368
  where
Ian Lynagh's avatar
Ian Lynagh committed
369
    need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
370
                 <+> ptext (sLit "to compare against the Real Thing")
371

Simon Peyton Jones's avatar
Simon Peyton Jones committed
372
    moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
373
                     <+> ptext (sLit "depends on itself")
374

Simon Peyton Jones's avatar
Simon Peyton Jones committed
375
    elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+>
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
376
                          quotes (ppr mod) <> colon) 4 err
377 378 379
\end{code}


380
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
381 382 383
%*                                                                      *
                Type and class declarations
%*                                                                      *
384 385 386 387 388 389 390
%************************************************************************

When typechecking a data type decl, we *lazily* (via forkM) typecheck
the constructor argument types.  This is in the hope that we may never
poke on those argument types, and hence may never need to load the
interface files for types mentioned in the arg types.

Simon Peyton Jones's avatar
Simon Peyton Jones committed
391
E.g.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
392
        data Foo.S = MkS Baz.T
393 394 395
Mabye we can get away without even loading the interface for Baz!

This is not just a performance thing.  Suppose we have
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
396 397
        data Foo.S = MkS Baz.T
        data Baz.T = MkT Foo.S
398
(in different interface files, of course).
Simon Peyton Jones's avatar
Simon Peyton Jones committed
399
Now, first we load and typecheck Foo.S, and add it to the type envt.
400
If we do explore MkS's argument, we'll load and typecheck Baz.T.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
401
If we explore MkT's argument we'll find Foo.S already in the envt.
402 403 404 405 406 407 408 409 410 411 412

If we typechecked constructor args eagerly, when loading Foo.S we'd try to
typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
which isn't done yet.

All very cunning. However, there is a rather subtle gotcha which bit
me when developing this stuff.  When we typecheck the decl for S, we
extend the type envt with S, MkS, and all its implicit Ids.  Suppose
(a bug, but it happened) that the list of implicit Ids depended in
turn on the constructor arg types.  Then the following sequence of
events takes place:
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
413 414 415
        * we build a thunk <t> for the constructor arg tys
        * we build a thunk for the extended type environment (depends on <t>)
        * we write the extended type envt into the global EPS mutvar
Simon Peyton Jones's avatar
Simon Peyton Jones committed
416

417
Now we look something up in the type envt
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
418 419 420
        * that pulls on <t>
        * which reads the global type envt out of the global EPS mutvar
        * but that depends in turn on <t>
421

Simon Peyton Jones's avatar
Simon Peyton Jones committed
422
It's subtle, because, it'd work fine if we typechecked the constructor args
423 424 425 426 427 428 429 430
eagerly -- they don't need the extended type envt.  They just get the extended
type envt by accident, because they look at it later.

What this means is that the implicitTyThings MUST NOT DEPEND on any of
the forkM stuff.


\begin{code}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
431 432 433
tcIfaceDecl :: Bool     -- True <=> discard IdInfo on IfaceId bindings
            -> IfaceDecl
            -> IfL TyThing
434 435
tcIfaceDecl = tc_iface_decl NoParentTyCon

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
436 437 438 439
tc_iface_decl :: TyConParent    -- For nested declarations
              -> Bool   -- True <=> discard IdInfo on IfaceId bindings
              -> IfaceDecl
              -> IfL TyThing
Simon Peyton Jones's avatar
Simon Peyton Jones committed
440
tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
441 442 443 444 445 446
                                       ifIdDetails = details, ifIdInfo = info})
  = do  { name <- lookupIfaceTop occ_name
        ; ty <- tcIfaceType iface_type
        ; details <- tcIdDetails ty details
        ; info <- tcIdInfo ignore_prags name ty info
        ; return (AnId (mkGlobalId details name ty info)) }
447

Simon Peyton Jones's avatar
Simon Peyton Jones committed
448 449
tc_iface_decl parent _ (IfaceData {ifName = occ_name,
                          ifCType = cType,
450 451
                          ifTyVars = tv_bndrs,
                          ifRoles = roles,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
452
                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
453 454
                          ifCons = rdr_cons,
                          ifRec = is_rec, ifPromotable = is_prom,
455
                          ifParent = mb_parent })
456 457
  = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
    { tc_name <- lookupIfaceTop occ_name
458
    ; tycon <- fixM $ \ tycon -> do
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
459
            { stupid_theta <- tcIfaceCtxt ctxt
460
            ; parent' <- tc_parent mb_parent
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
461
            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
Simon Peyton Jones's avatar
Simon Peyton Jones committed
462
            ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
463
                                    cons is_rec is_prom gadt_syn parent') }
464 465
    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
    ; return (ATyCon tycon) }
466
  where
467 468 469
    tc_parent :: IfaceTyConParent -> IfL TyConParent
    tc_parent IfNoParent = return parent
    tc_parent (IfDataInstance ax_name _ arg_tys)
470 471
      = ASSERT( isNoParent parent )
        do { ax <- tcIfaceCoAxiom ax_name
472
           ; let fam_tc  = coAxiomTyCon ax
473
                 ax_unbr = toUnbranchedAxiom ax
474
           ; lhs_tys <- tcIfaceTcArgs arg_tys
475
           ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
476

Simon Peyton Jones's avatar
Simon Peyton Jones committed
477
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
478
                                  ifRoles = roles,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
479
                                  ifSynRhs = mb_rhs_ty,
480
                                  ifSynKind = kind })
481
   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
482
     { tc_name  <- lookupIfaceTop occ_name
483
     ; rhs_kind <- tcIfaceKind kind     -- Note [Synonym kind loop]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
484
     ; rhs      <- forkM (mk_doc tc_name) $
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
485
                   tc_syn_rhs mb_rhs_ty
486
     ; tycon    <- buildSynTyCon tc_name tyvars roles rhs rhs_kind parent
487
     ; return (ATyCon tycon) }
488 489
   where
     mk_doc n = ptext (sLit "Type syonym") <+> ppr n
490
     tc_syn_rhs IfaceOpenSynFamilyTyCon   = return OpenSynFamilyTyCon
491
     tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name _)
492 493
       = do { ax <- tcIfaceCoAxiom ax_name
            ; return (ClosedSynFamilyTyCon ax) }
494
     tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon
495 496
     tc_syn_rhs (IfaceSynonymTyCon ty)    = do { rhs_ty <- tcIfaceType ty
                                               ; return (SynonymTyCon rhs_ty) }
497 498
     tc_syn_rhs IfaceBuiltInSynFamTyCon   = pprPanic "tc_iface_decl"
                                               (ptext (sLit "IfaceBuiltInSynFamTyCon in interface file"))
499

500
tc_iface_decl _parent ignore_prags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
501
            (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
502 503
                         ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds,
                         ifATs = rdr_ats, ifSigs = rdr_sigs,
504
                         ifMinDef = mindef_occ, ifRec = tc_isrec })
505
-- ToDo: in hs-boot files we should really treat abstract classes specially,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
506
--       as we do abstract tycons
507
  = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
batterseapower's avatar
batterseapower committed
508
    { tc_name <- lookupIfaceTop tc_occ
509 510 511
    ; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
    ; ctxt <- mapM tc_sc rdr_ctxt
    ; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
512 513
    ; sigs <- mapM tc_sig rdr_sigs
    ; fds  <- mapM tc_fd rdr_fds
514
    ; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
515
    ; mindef <- traverse lookupIfaceTop mindef_occ
516
    ; cls  <- fixM $ \ cls -> do
517
              { ats  <- mapM (tc_at cls) rdr_ats
518
              ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
519
              ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
batterseapower's avatar
batterseapower committed
520
    ; return (ATyCon (classTyCon cls)) }
521
  where
522 523 524 525 526 527 528 529 530
   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
        -- The *length* of the superclasses is used by buildClass, and hence must
        -- not be inside the thunk.  But the *content* maybe recursive and hence
        -- must be lazy (via forkM).  Example:
        --     class C (T a) => D a where
        --       data T a
        -- Here the associated type T is knot-tied with the class, and
        -- so we must not pull on T too eagerly.  See Trac #5970

531 532
   tc_sig (IfaceClassOp occ dm rdr_ty)
     = do { op_name <- lookupIfaceTop occ
533
          ; op_ty   <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
534
                -- Must be done lazily for just the same reason as the
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
535
                -- type of a data con; to avoid sucking in types that
536
                -- it mentions unless it's necessary to do so
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
537
          ; return (op_name, dm, op_ty) }
538

539
   tc_at cls (IfaceAT tc_decl defs_decls)
540
     = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
541
          defs <- forkM (mk_at_doc tc) (tc_ax_branches defs_decls)
542 543 544
                  -- Must be done lazily in case the RHS of the defaults mention
                  -- the type constructor being defined here
                  -- e.g.   type AT a; type AT b = AT [b]   Trac #8002
545 546
          return (tc, defs)

547 548
   mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
   mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc
549
   mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
550

551
   tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
552 553
                           ; tvs2' <- mapM tcIfaceTyVar tvs2
                           ; return (tvs1', tvs2') }
554

555
tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
556
  = do  { name <- lookupIfaceTop rdr_name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
557
        ; return (ATyCon (mkForeignTyCon name ext_name
558
                                         liftedTypeKind)) }
559

560 561
tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
                              , ifAxBranches = branches, ifRole = role })
562 563
  = do { tc_name     <- lookupIfaceTop ax_occ
       ; tc_tycon    <- tcIfaceTyCon tc
564
       ; tc_branches <- tc_ax_branches branches
565
       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
566 567
                             , co_ax_name     = tc_name
                             , co_ax_tc       = tc_tycon
568
                             , co_ax_role     = role
569 570 571
                             , co_ax_branches = toBranchList tc_branches
                             , co_ax_implicit = False }
       ; return (ACoAxiom axiom) }
572

Gergő Érdi's avatar
Gergő Érdi committed
573
tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
574 575
                              , ifPatMatcher = matcher_name
                              , ifPatWrapper = wrapper_name
Gergő Érdi's avatar
Gergő Érdi committed
576 577 578 579 580 581 582 583 584
                              , ifPatIsInfix = is_infix
                              , ifPatUnivTvs = univ_tvs
                              , ifPatExTvs = ex_tvs
                              , ifPatProvCtxt = prov_ctxt
                              , ifPatReqCtxt = req_ctxt
                              , ifPatArgs = args
                              , ifPatTy = pat_ty })
  = do { name <- lookupIfaceTop occ_name
       ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
585 586 587 588 589
       ; matcher <- tcExt "Matcher" matcher_name
       ; wrapper <- case wrapper_name of
                        Nothing -> return Nothing
                        Just wn -> do { wid <- tcExt "Wrapper" wn
                                      ; return (Just wid) }
Gergő Érdi's avatar
Gergő Érdi committed
590 591
       ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
       { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
592
       { patsyn <- forkM (mk_doc name) $
Gergő Érdi's avatar
Gergő Érdi committed
593 594 595
             do { prov_theta <- tcIfaceCtxt prov_ctxt
                ; req_theta  <- tcIfaceCtxt req_ctxt
                ; pat_ty     <- tcIfaceType pat_ty
596 597 598 599
                ; arg_tys    <- mapM tcIfaceType args
                ; return $ buildPatSyn name is_infix matcher wrapper
                                       arg_tys univ_tvs ex_tvs prov_theta req_theta pat_ty }
       ; return $ AConLike . PatSynCon $ patsyn }}}
Gergő Érdi's avatar
Gergő Érdi committed
600 601
  where
     mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
602
     tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name
Gergő Érdi's avatar
Gergő Érdi committed
603

604 605
tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
606

607 608
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch prev_branches
609 610
             (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
                            , ifaxbRoles = roles, ifaxbIncomps = incomps })
611 612
  = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do
         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
613
    { tc_lhs <- tcIfaceTcArgs lhs   -- See Note [Checking IfaceTypes vs IfaceKinds]
614
    ; tc_rhs <- tcIfaceType rhs
615 616 617 618 619
    ; let br = CoAxBranch { cab_loc     = noSrcSpan
                          , cab_tvs     = tvs
                          , cab_lhs     = tc_lhs
                          , cab_roles   = roles
                          , cab_rhs     = tc_rhs
620 621
                          , cab_incomps = map (prev_branches !!) incomps }
    ; return (prev_branches ++ [br]) }
622

Ian Lynagh's avatar
Ian Lynagh committed
623 624
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
625
  = case if_cons of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
626
        IfAbstractTyCon dis -> return (AbstractTyCon dis)
627
        IfDataFamTyCon  -> return DataFamilyTyCon
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
628 629 630 631
        IfDataTyCon cons -> do  { data_cons <- mapM tc_con_decl cons
                                ; return (mkDataTyConRhs data_cons) }
        IfNewTyCon con   -> do  { data_con <- tc_con_decl con
                                ; mkNewTyConRhs tycon_name tycon data_con }
632
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
633
    tc_con_decl (IfCon { ifConInfix = is_infix,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
634 635 636
                         ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
                         ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                         ifConArgTys = args, ifConFields = field_lbls,
637
                         ifConStricts = if_stricts})
638
     = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
639
       bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
640 641
        { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
        ; name  <- lookupIfaceTop occ
642 643

        -- Read the context and argument types, but lazily for two reasons
Simon Peyton Jones's avatar
Simon Peyton Jones committed
644
        -- (a) to avoid looking tugging on a recursive use of
645
        --     the type itself, which is knot-tied
Simon Peyton Jones's avatar
Simon Peyton Jones committed
646
        -- (b) to avoid faulting in the component types unless
647
        --     they are really needed
648
        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $
649 650 651
             do { eq_spec <- tcIfaceEqSpec spec
                ; theta   <- tcIfaceCtxt ctxt
                ; arg_tys <- mapM tcIfaceType args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
652 653
                ; stricts <- mapM tc_strict if_stricts
                        -- The IfBang field can mention
654 655
                        -- the type itself; hence inside forkM
                ; return (eq_spec, theta, arg_tys, stricts) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
656 657 658
        ; lbl_names <- mapM lookupIfaceTop field_lbls

        -- Remember, tycon is the representation tycon
Simon Peyton Jones's avatar
Simon Peyton Jones committed
659
        ; let orig_res_ty = mkFamilyTyConApp tycon
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
660 661
                                (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)

662
        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
663
                       name is_infix
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
664
                       stricts lbl_names
Simon Peyton Jones's avatar
Simon Peyton Jones committed
665 666
                       univ_tyvars ex_tyvars
                       eq_spec theta
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
667
                       arg_tys orig_res_ty tycon
668
        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
669
        ; return con }
Ian Lynagh's avatar
Ian Lynagh committed
670
    mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
671

672 673 674 675 676 677
    tc_strict IfNoBang = return HsNoBang
    tc_strict IfStrict = return HsStrict
    tc_strict IfUnpack = return (HsUnpack Nothing)
    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
                                      ; return (HsUnpack (Just co)) }

678
tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)]
679 680 681
tcIfaceEqSpec spec
  = mapM do_item spec
  where
682
    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
683 684
                              ; ty <- tcIfaceType if_ty
                              ; return (tv,ty) }
685
\end{code}
686

687 688 689
Note [Synonym kind loop]
~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we eagerly grab the *kind* from the interface file, but
Simon Peyton Jones's avatar
Simon Peyton Jones committed
690
build a forkM thunk for the *rhs* (and family stuff).  To see why,
691 692 693 694 695 696 697 698 699 700 701 702 703
consider this (Trac #2412)

M.hs:       module M where { import X; data T = MkT S }
X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
M.hs-boot:  module M where { data T }

When kind-checking M.hs we need S's kind.  But we do not want to
find S's kind from (typeKind S-rhs), because we don't want to look at
S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
be defined, and we must not do that until we've finished with M.T.

Solution: record S's kind in the interface file; now we can safely
look at it.
704 705

%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
706 707 708
%*                                                                      *
                Instances
%*                                                                      *
709 710 711
%************************************************************************

\begin{code}
712
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
713 714
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
                          , ifInstCls = cls, ifInstTys = mb_tcs })
715 716
  = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
                 tcIfaceExtId dfun_occ
717
       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
718
       ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
719

720 721 722
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
                             , ifFamInstAxiom = axiom_name } )
723 724
    = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
                     tcIfaceCoAxiom axiom_name
725 726 727 728
             -- will panic if branched, but that's OK
         ; let axiom'' = toUnbranchedAxiom axiom'
               mb_tcs' = map (fmap ifaceTyConName) mb_tcs
         ; return (mkImportedFamInst fam mb_tcs' axiom'') }
729 730
\end{code}

731

732
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
733 734 735
%*                                                                      *
                Rules
%*                                                                      *
736 737 738
%************************************************************************

We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
Simon Peyton Jones's avatar
Simon Peyton Jones committed
739
are in the type environment.  However, remember that typechecking a Rule may
740 741 742
(as a side effect) augment the type envt, and so we may need to iterate the process.

\begin{code}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
743 744 745
tcIfaceRules :: Bool            -- True <=> ignore rules
             -> [IfaceRule]
             -> IfL [CoreRule]
746 747 748 749
tcIfaceRules ignore_prags if_rules
  | ignore_prags = return []
  | otherwise    = mapM tcIfaceRule if_rules

750 751
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
752
                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
753
                        ifRuleAuto = auto })
Simon Peyton Jones's avatar
Simon Peyton Jones committed
754
  = do  { ~(bndrs', args', rhs') <-
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
755 756 757 758 759 760 761
                -- Typecheck the payload lazily, in the hope it'll never be looked at
                forkM (ptext (sLit "Rule") <+> ftext name) $
                bindIfaceBndrs bndrs                      $ \ bndrs' ->
                do { args' <- mapM tcIfaceExpr args
                   ; rhs'  <- tcIfaceExpr rhs
                   ; return (bndrs', args', rhs') }
        ; let mb_tcs = map ifTopFreeName args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
762 763 764
        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
                          ru_bndrs = bndrs', ru_args = args',
                          ru_rhs = occurAnalyseExpr rhs',
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
765
                          ru_rough = mb_tcs,
766
                          ru_auto = auto,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
767 768 769
                          ru_local = False }) } -- An imported RULE is never for a local Id
                                                -- or, even if it is (module loop, perhaps)
                                                -- we'll just leave it in the non-local set
770
  where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
771 772 773 774 775 776 777
        -- This function *must* mirror exactly what Rules.topFreeName does
        -- We could have stored the ru_rough field in the iface file
        -- but that would be redundant, I think.
        -- The only wrinkle is that we must not be deceived by
        -- type syononyms at the top of a type arg.  Since
        -- we can't tell at this point, we are careful not
        -- to write them out in coreRuleToIfaceRule
778 779
    ifTopFreeName :: IfaceExpr -> Maybe Name
    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
Ian Lynagh's avatar
Ian Lynagh committed
780
    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
781
    ifTopFreeName (IfaceExt n)                      = Just n
Ian Lynagh's avatar
Ian Lynagh committed
782
    ifTopFreeName _                                 = Nothing
783 784 785
\end{code}


786
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
787 788 789
%*                                                                      *
                Annotations
%*                                                                      *
790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813
%************************************************************************

\begin{code}
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceAnnotations = mapM tcIfaceAnnotation

tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
tcIfaceAnnotation (IfaceAnnotation target serialized) = do
    target' <- tcIfaceAnnTarget target
    return $ Annotation {
        ann_target = target',
        ann_value = serialized
    }

tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget (NamedTarget occ) = do
    name <- lookupIfaceTop occ
    return $ NamedTarget name
tcIfaceAnnTarget (ModuleTarget mod) = do
    return $ ModuleTarget mod

\end{code}


chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
814
%************************************************************************
815 816 817
%*                                                                      *
                Vectorisation information
%*                                                                      *
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
818 819 820
%************************************************************************

\begin{code}
821
-- We need access to the type environment as we need to look up information about type constructors
822 823 824 825 826
-- (i.e., their data constructors and whether they are class type constructors).  If a vectorised
-- type constructor or class is defined in the same module as where it is vectorised, we cannot
-- look that information up from the type constructor that we obtained via a 'forkM'ed
-- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
-- and again and again...
827 828
--
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
Simon Peyton Jones's avatar
Simon Peyton Jones committed
829
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
830 831 832 833 834
                             { ifaceVectInfoVar            = vars
                             , ifaceVectInfoTyCon          = tycons
                             , ifaceVectInfoTyConReuse     = tyconsReuse
                             , ifaceVectInfoParallelVars   = parallelVars
                             , ifaceVectInfoParallelTyCons = parallelTyCons
835
                             })
836 837
  = do { let parallelTyConsSet = mkNameSet parallelTyCons
       ; vVars         <- mapM vectVarMapping                  vars
838
       ; let varsSet = mkVarSet (map fst vVars)
839 840 841
       ; tyConRes1     <- mapM (vectTyConVectMapping varsSet)  tycons
       ; tyConRes2     <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
       ; vParallelVars <- mapM vectVar                         parallelVars
842
       ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
843
       ; return $ VectInfo
844 845 846 847 848
                  { vectInfoVar            = mkVarEnv  vVars `extendVarEnvList` concat vScSels
                  , vectInfoTyCon          = mkNameEnv vTyCons
                  , vectInfoDataCon        = mkNameEnv (concat vDataCons)
                  , vectInfoParallelVars   = mkVarSet  vParallelVars
                  , vectInfoParallelTyCons = parallelTyConsSet
849
                  }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
850 851
       }
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
852
    vectVarMapping name
853
      = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
854 855
           ; var   <- forkM (ptext (sLit "vect var")  <+> ppr name)  $
                        tcIfaceExtId name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
856 857
           ; vVar  <- forkM (ptext (sLit "vect vVar [mod =") <+>
                             ppr mod <> ptext (sLit "; nameModule =") <+>
858 859
                             ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
                       tcIfaceExtId vName
860
           ; return (var, (var, vVar))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
861
           }
862 863 864 865 866 867 868 869 870 871 872
      -- where
      --   lookupLocalOrExternalId name
      --     = do { let mb_id = lookupTypeEnv typeEnv name
      --          ; case mb_id of
      --                -- id is local
      --              Just (AnId id) -> return id
      --                -- name is not an Id => internal inconsistency
      --              Just _         -> notAnIdErr
      --                -- Id is external
      --              Nothing        -> tcIfaceExtId name
      --          }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
873
      --
874
      --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
875

Simon Peyton Jones's avatar
Simon Peyton Jones committed
876
    vectVar name
877 878 879
      = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
          tcIfaceExtId name

880
    vectTyConVectMapping vars name
881
      = do { vName  <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
882 883 884 885 886 887 888
           ; vectTyConMapping vars name vName
           }

    vectTyConReuseMapping vars name
      = vectTyConMapping vars name name

    vectTyConMapping vars name vName
889
      = do { tycon  <- lookupLocalOrExternalTyCon name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
890
           ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $
chak@cse.unsw.edu.au.'s avatar