TcIface.lhs 66 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
9

\begin{code}
module TcIface ( 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
10
11
        tcImportDecl, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, 
        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
12
13
14
15
        tcIfaceVectInfo, tcIfaceAnnotations, 
        tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
        tcIfaceGlobal, 
        tcExtCoreBindings
16
 ) where
17

18
19
20
#include "HsVersions.h"

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

69
import Control.Monad
70
71
72
73
\end{code}

This module takes

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
74
75
76
        IfaceDecl -> TyThing
        IfaceType -> Type
        etc
77
78
79
80

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
81
82
83
84
85
86
87
88
89
        -- 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.
90
91

%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
92
93
94
95
%*                                                                      *
%*      tcImportDecl is the key function for "faulting in"              *
%*      imported things
%*                                                                      *
96
97
98
99
100
%************************************************************************

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
it in the EPS type envt.  So it 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
101
102
103
104
        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
105
106
107
108
109
110

Note that DURING STEP 4, we may find that map's type mentions a type 
constructor that also 

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
111
        ...$(e1)...$(e2)...
112
113
114
115
where the code that e1 expands to might import some defns that 
also turn out to be needed by the code that e2 expands to.

\begin{code}
116
tcImportDecl :: Name -> TcM TyThing
117
-- Entry point for *source-code* uses of importDecl
118
tcImportDecl name 
119
  | Just thing <- wiredInNameTyThing_maybe name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
120
121
122
123
  = do  { when (needWiredInHomeIface thing)
               (initIfaceTcRn (loadWiredInHomeIface name))
                -- See Note [Loading instances for wired-in things]
        ; return thing }
124
  | otherwise
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
125
126
127
128
129
  = do  { traceIf (text "tcImportDecl" <+> ppr name)
        ; mb_thing <- initIfaceTcRn (importDecl name)
        ; case mb_thing of
            Succeeded thing -> return thing
            Failed err      -> failWithTc err }
130

131
importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
132
-- Get the TyThing for this Name from an interface file
133
134
135
-- 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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
    do  { traceIf nd_doc

        -- Load the interface, which should populate the PTE
        ; mb_iface <- ASSERT2( isExternalName name, ppr name ) 
                      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
        { eps <- getEps 
        ; case lookupTypeEnv (eps_PTE eps) name of
            Just thing -> return (Succeeded thing)
            Nothing    -> return (Failed not_found_msg)
150
    }}}
151
  where
Ian Lynagh's avatar
Ian Lynagh committed
152
153
    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
154
155
156
                                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")])
157
158
\end{code}

159
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
160
%*                                                                      *
161
           Checks for wired-in things
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
162
%*                                                                      *
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
%************************************************************************

Note [Loading instances for wired-in things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to make sure that we have at least *read* the interface files
for any module with an instance decl or RULE that we might want.  

* 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.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
198
checkWiredInTyCon tc    
199
200
201
  | not (isWiredInName tc_name) 
  = return ()
  | otherwise
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
202
203
204
205
206
207
208
209
  = do  { mod <- getModule
        ; ASSERT( isExternalName tc_name ) 
          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
        }
210
211
212
213
214
215
216
217
218
  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
219
220
221
222
223
224
  = 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
225
        ; let name = getName thing
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
226
227
228
        ; ASSERT2( isExternalName name, ppr name ) 
          when (needWiredInHomeIface thing && mod /= nameModule name)
               (loadWiredInHomeIface name) }
229
230
231
232
233
234
235

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

236
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
237
238
239
%*                                                                      *
                Type-checking a complete interface
%*                                                                      *
240
241
%************************************************************************

242
243
244
245
246
247
248
249
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.

250
\begin{code}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
251
252
typecheckIface :: ModIface      -- Get the decls from here
               -> TcRnIf gbl lcl ModDetails
253
254
typecheckIface iface
  = initIfaceTc iface $ \ tc_env_var -> do
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
255
256
257
258
259
260
261
        -- The tc_env_var is freshly allocated, private to 
        -- 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
                -- It's not actually *wrong* to do so, but in fact GHCi is unable 
                -- to handle unboxed tuples, so it must not see unfoldings.
ian@well-typed.com's avatar
ian@well-typed.com committed
262
          ignore_prags <- goptM Opt_IgnoreInterfacePragmas
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
263
264
265
266
267
268
269
270
271
272
273
274
275
276

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

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
278
                -- Vectorisation information
279
        ; 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
280

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
281
282
283
284
285
286
287
288
289
290
291
                -- 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
292
                              , md_vect_info = vect_info
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
293
294
                              , md_exports   = exports
                              }
295
    }
296
297
298
\end{code}


299
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
300
301
302
%*                                                                      *
                Type and class declarations
%*                                                                      *
303
304
305
%************************************************************************

\begin{code}
306
tcHiBootIface :: HscSource -> Module -> TcRn ModDetails
307
308
309
-- 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
310
tcHiBootIface hsc_src mod
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
311
  | isHsBoot hsc_src            -- Already compiling a hs-boot file
312
313
  = return emptyModDetails
  | otherwise
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
  = 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
                -- 
                -- We check wheher the interface is a *boot* interface.
                -- It can happen (when using GHC from Visual Studio) that we
                -- compile a module in TypecheckOnly mode, with a stable, 
                -- 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.
                -- And that's fine, because if M's ModInfo is in the HPT, then 
                -- 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
                      Just info | mi_boot (hm_iface info) 
                                -> return (hm_details info)
                      _ -> return emptyModDetails }
          else do

        -- 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 
        -- 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
                
            Just (_mod, True) ->        -- There's a hi-boot interface below us
                
    do  { read_result <- findAndReadIface 
                                need mod
                                True    -- Hi-boot file

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

Ian Lynagh's avatar
Ian Lynagh committed
361
    moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
362
                     <+> ptext (sLit "depends on itself")
363

Ian Lynagh's avatar
Ian Lynagh committed
364
    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
365
                          quotes (ppr mod) <> colon) 4 err
366
367
368
\end{code}


369
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
370
371
372
%*                                                                      *
                Type and class declarations
%*                                                                      *
373
374
375
376
377
378
379
%************************************************************************

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.

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
380
381
E.g.    
        data Foo.S = MkS Baz.T
382
383
384
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
385
386
        data Foo.S = MkS Baz.T
        data Baz.T = MkT Foo.S
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
(in different interface files, of course).
Now, first we load and typecheck Foo.S, and add it to the type envt.  
If we do explore MkS's argument, we'll load and typecheck Baz.T.
If we explore MkT's argument we'll find Foo.S already in the envt.  

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
402
403
404
405
        * 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
        
406
Now we look something up in the type envt
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
407
408
409
        * that pulls on <t>
        * which reads the global type envt out of the global EPS mutvar
        * but that depends in turn on <t>
410
411
412
413
414
415
416
417
418
419

It's subtle, because, it'd work fine if we typechecked the constructor args 
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
420
421
422
tcIfaceDecl :: Bool     -- True <=> discard IdInfo on IfaceId bindings
            -> IfaceDecl
            -> IfL TyThing
423
424
tcIfaceDecl = tc_iface_decl NoParentTyCon

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
425
426
427
428
tc_iface_decl :: TyConParent    -- For nested declarations
              -> Bool   -- True <=> discard IdInfo on IfaceId bindings
              -> IfaceDecl
              -> IfL TyThing
429
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
430
431
432
433
434
435
                                       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)) }
436

437
tc_iface_decl parent _ (IfaceData {ifName = occ_name, 
438
                          ifCType = cType, 
439
440
                          ifTyVars = tv_bndrs,
                          ifRoles = roles,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
441
442
                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                          ifCons = rdr_cons, 
443
                          ifRec = is_rec, ifPromotable = is_prom, 
444
                          ifAxiom = mb_axiom_name })
445
446
  = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
    { tc_name <- lookupIfaceTop occ_name
447
    ; tycon <- fixM $ \ tycon -> do
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
448
            { stupid_theta <- tcIfaceCtxt ctxt
449
            ; parent' <- tc_parent tyvars mb_axiom_name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
450
            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
451
            ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta 
452
                                    cons is_rec is_prom gadt_syn parent') }
453
454
    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
    ; return (ATyCon tycon) }
455
456
457
458
459
460
  where
    tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent
    tc_parent _ Nothing = return parent
    tc_parent tyvars (Just ax_name)
      = ASSERT( isNoParent parent )
        do { ax <- tcIfaceCoAxiom ax_name
461
462
463
           ; let fam_tc = coAxiomTyCon ax
                 ax_unbr = toUnbranchedAxiom ax
                 -- data families don't have branches:
464
465
466
467
468
                 branch    = coAxiomSingleBranch ax_unbr
                 ax_tvs    = coAxBranchTyVars branch
                 ax_lhs    = coAxBranchLHS branch
                 tycon_tys = mkTyVarTys tyvars
                 subst     = mkTopTvSubst (ax_tvs `zip` tycon_tys)
469
470
471
472
                            -- The subst matches the tyvar of the TyCon
                            -- with those from the CoAxiom.  They aren't
                            -- necessarily the same, since the two may be
                            -- gotten from separate interface-file declarations
473
474
475
476
477
478
479
                            -- NB: ax_tvs may be shorter because of eta-reduction
                            -- See Note [Eta reduction for data family axioms] in TcInstDcls
                 lhs_tys = substTys subst ax_lhs `chkAppend` 
                           dropList ax_tvs tycon_tys
                            -- The 'lhs_tys' should be 1-1 with the 'tyvars'
                            -- but ax_tvs maybe shorter because of eta-reduction
           ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
480

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

502
tc_iface_decl _parent ignore_prags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
503
            (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
504
                         ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
505
506
                         ifATs = rdr_ats, ifSigs = rdr_sigs, 
                         ifRec = tc_isrec })
507
-- 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
508
--       as we do abstract tycons
509
  = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
batterseapower's avatar
batterseapower committed
510
    { tc_name <- lookupIfaceTop tc_occ
511
512
513
    ; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
    ; ctxt <- mapM tc_sc rdr_ctxt
    ; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
514
515
    ; sigs <- mapM tc_sig rdr_sigs
    ; fds  <- mapM tc_fd rdr_fds
516
    ; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
517
    ; cls  <- fixM $ \ cls -> do
518
              { ats  <- mapM (tc_at cls) rdr_ats
519
              ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
520
              ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs tc_isrec }
batterseapower's avatar
batterseapower committed
521
    ; return (ATyCon (classTyCon cls)) }
522
  where
523
524
525
526
527
528
529
530
531
   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

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

540
   tc_at cls (IfaceAT tc_decl defs_decls)
541
     = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
542
543
544
545
546
          defs <- forkM (mk_at_doc tc) $
                  foldlM tc_ax_branches [] defs_decls
                  -- 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
547
548
          return (tc, defs)

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

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

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

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

576
577
578
tc_ax_branches :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branches prev_branches
               (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
579
                              , ifaxbRoles = roles, ifaxbIncomps = incomps })
580
581
582
  = bindIfaceTyVars tv_bndrs $ \ tvs -> do  -- Variables will all be fresh
    { tc_lhs <- mapM tcIfaceType lhs
    ; tc_rhs <- tcIfaceType rhs
583
584
585
586
587
    ; let br = CoAxBranch { cab_loc     = noSrcSpan
                          , cab_tvs     = tvs
                          , cab_lhs     = tc_lhs
                          , cab_roles   = roles
                          , cab_rhs     = tc_rhs
588
589
                          , cab_incomps = map (prev_branches !!) incomps }
    ; return (prev_branches ++ [br]) }
590

Ian Lynagh's avatar
Ian Lynagh committed
591
592
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon _ if_cons
593
  = case if_cons of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
594
        IfAbstractTyCon dis -> return (AbstractTyCon dis)
595
        IfDataFamTyCon  -> return DataFamilyTyCon
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
596
597
598
599
        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 }
600
  where
601
    tc_con_decl (IfCon { ifConInfix = is_infix, 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
602
603
604
                         ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
                         ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                         ifConArgTys = args, ifConFields = field_lbls,
605
                         ifConStricts = if_stricts})
606
     = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
607
608
       bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
        { name  <- lookupIfaceTop occ
609
610
611
612
613
614
615
616
617
618
619

        -- Read the context and argument types, but lazily for two reasons
        -- (a) to avoid looking tugging on a recursive use of 
        --     the type itself, which is knot-tied
        -- (b) to avoid faulting in the component types unless 
        --     they are really needed
        ; ~(eq_spec, theta, arg_tys) <- forkM (mk_doc name) $
             do { eq_spec <- tcIfaceEqSpec spec
                ; theta   <- tcIfaceCtxt ctxt
                ; arg_tys <- mapM tcIfaceType args
                ; return (eq_spec, theta, arg_tys) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
620
621
        ; lbl_names <- mapM lookupIfaceTop field_lbls

622
623
        ; stricts <- mapM tc_strict if_stricts

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
624
625
626
627
        -- Remember, tycon is the representation tycon
        ; let orig_res_ty = mkFamilyTyConApp tycon 
                                (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)

628
629
        ; buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
                       name is_infix
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
630
631
                       stricts lbl_names
                       univ_tyvars ex_tyvars 
632
                       eq_spec theta 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
633
634
                       arg_tys orig_res_ty tycon
        }
Ian Lynagh's avatar
Ian Lynagh committed
635
    mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
636

637
638
639
640
641
642
    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)) }

Ian Lynagh's avatar
Ian Lynagh committed
643
tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
644
645
646
tcIfaceEqSpec spec
  = mapM do_item spec
  where
647
    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
648
649
                              ; ty <- tcIfaceType if_ty
                              ; return (tv,ty) }
650
\end{code}
651

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
Note [Synonym kind loop]
~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we eagerly grab the *kind* from the interface file, but
build a forkM thunk for the *rhs* (and family stuff).  To see why, 
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.
669
670

%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
671
672
673
%*                                                                      *
                Instances
%*                                                                      *
674
675
676
%************************************************************************

\begin{code}
677
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
678
679
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
                          , ifInstCls = cls, ifInstTys = mb_tcs })
680
681
  = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
                 tcIfaceExtId dfun_occ
682
       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
683
       ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
684

685
686
687
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
                             , ifFamInstAxiom = axiom_name } )
688
689
    = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
                     tcIfaceCoAxiom axiom_name
690
691
692
693
             -- 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'') }
694
695
\end{code}

696

697
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
698
699
700
%*                                                                      *
                Rules
%*                                                                      *
701
702
703
704
705
706
707
%************************************************************************

We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
are in the type environment.  However, remember that typechecking a Rule may 
(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
708
709
710
tcIfaceRules :: Bool            -- True <=> ignore rules
             -> [IfaceRule]
             -> IfL [CoreRule]
711
712
713
714
tcIfaceRules ignore_prags if_rules
  | ignore_prags = return []
  | otherwise    = mapM tcIfaceRule if_rules

715
716
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
717
                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
718
                        ifRuleAuto = auto })
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
719
720
721
722
723
724
725
726
727
728
729
730
  = do  { ~(bndrs', args', rhs') <- 
                -- 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
        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, 
                          ru_bndrs = bndrs', ru_args = args', 
                          ru_rhs = occurAnalyseExpr rhs', 
                          ru_rough = mb_tcs,
731
                          ru_auto = auto,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
732
733
734
                          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
735
  where
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
736
737
738
739
740
741
742
        -- 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
743
744
    ifTopFreeName :: IfaceExpr -> Maybe Name
    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
Ian Lynagh's avatar
Ian Lynagh committed
745
    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
746
    ifTopFreeName (IfaceExt n)                      = Just n
Ian Lynagh's avatar
Ian Lynagh committed
747
    ifTopFreeName _                                 = Nothing
748
749
750
\end{code}


751
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
752
753
754
%*                                                                      *
                Annotations
%*                                                                      *
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
%************************************************************************

\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
779
%************************************************************************
780
781
782
%*                                                                      *
                Vectorisation information
%*                                                                      *
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
783
784
785
%************************************************************************

\begin{code}
786
-- We need access to the type environment as we need to look up information about type constructors
787
788
789
790
791
-- (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...
792
793
794
--
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
795
796
797
798
799
                             { ifaceVectInfoVar            = vars
                             , ifaceVectInfoTyCon          = tycons
                             , ifaceVectInfoTyConReuse     = tyconsReuse
                             , ifaceVectInfoParallelVars   = parallelVars
                             , ifaceVectInfoParallelTyCons = parallelTyCons
800
                             })
801
802
  = do { let parallelTyConsSet = mkNameSet parallelTyCons
       ; vVars         <- mapM vectVarMapping                  vars
803
       ; let varsSet = mkVarSet (map fst vVars)
804
805
806
       ; tyConRes1     <- mapM (vectTyConVectMapping varsSet)  tycons
       ; tyConRes2     <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
       ; vParallelVars <- mapM vectVar                         parallelVars
807
       ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
808
       ; return $ VectInfo 
809
810
811
812
813
                  { vectInfoVar            = mkVarEnv  vVars `extendVarEnvList` concat vScSels
                  , vectInfoTyCon          = mkNameEnv vTyCons
                  , vectInfoDataCon        = mkNameEnv (concat vDataCons)
                  , vectInfoParallelVars   = mkVarSet  vParallelVars
                  , vectInfoParallelTyCons = parallelTyConsSet
814
                  }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
815
816
       }
  where
817
    vectVarMapping name 
818
      = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
819
820
821
822
823
824
           ; var   <- forkM (ptext (sLit "vect var")  <+> ppr name)  $
                        tcIfaceExtId name
           ; vVar  <- forkM (ptext (sLit "vect vVar [mod =") <+> 
                             ppr mod <> ptext (sLit "; nameModule =") <+> 
                             ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
                       tcIfaceExtId vName
825
           ; return (var, (var, vVar))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
826
           }
827
828
829
830
831
832
833
834
835
836
837
838
839
      -- 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
      --          }
      -- 
      --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
840
841
842
843
844

    vectVar name 
      = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
          tcIfaceExtId name

845
    vectTyConVectMapping vars name
846
      = do { vName  <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
847
848
849
850
851
852
853
           ; vectTyConMapping vars name vName
           }

    vectTyConReuseMapping vars name
      = vectTyConMapping vars name name

    vectTyConMapping vars name vName
854
855
856
      = do { tycon  <- lookupLocalOrExternalTyCon name
           ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ 
                         lookupLocalOrExternalTyCon vName
857

858
               -- Map the data constructors of the original type constructor to those of the
859
860
               -- vectorised type constructor /unless/ the type constructor was vectorised
               -- abstractly; if it was vectorised abstractly, the workers of its data constructors
861
862
863
864
               -- do not appear in the set of vectorised variables.
               --
               -- NB: This is lazy!  We don't pull at the type constructors before we actually use
               --     the data constructor mapping.
865
866
867
868
869
870
871
872
873
           ; let isAbstract | isClassTyCon tycon = False
                            | datacon:_ <- tyConDataCons tycon 
                                                 = not $ dataConWrapId datacon `elemVarSet` vars
                            | otherwise          = True
                 vDataCons  | isAbstract = []
                            | otherwise  = [ (dataConName datacon, (datacon, vDatacon))
                                           | (datacon, vDatacon) <- zip (tyConDataCons tycon)
                                                                        (tyConDataCons vTycon)
                                           ]
874

875
876
877
878
879
880
881
882
883
884
                   -- Map the (implicit) superclass and methods selectors as they don't occur in
                   -- the var map.
                 vScSels    | Just cls  <- tyConClass_maybe tycon
                            , Just vCls <- tyConClass_maybe vTycon 
                            = [ (sel, (sel, vSel))
                              | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
                              ]
                            | otherwise
                            = []

885
886
           ; return ( (name, (tycon, vTycon))          -- (T, T_v)
                    , vDataCons                        -- list of (Ci, Ci_v)
887
                    , vScSels                          -- list of (seli, seli_v)
888
                    )
889
           }
890
      where
891
892
          -- we need a fully defined version of the type constructor to be able to extract
          -- its data constructors etc.
893
        lookupLocalOrExternalTyCon name
894
895
896
897
898
899
900
901
902
          = do { let mb_tycon = lookupTypeEnv typeEnv name
               ; case mb_tycon of
                     -- tycon is local
                   Just (ATyCon tycon) -> return tycon
                     -- name is not a tycon => internal inconsistency
                   Just _              -> notATyConErr
                     -- tycon is external
                   Nothing             -> tcIfaceTyCon (IfaceTc name)
               }
903

904
        notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
905
906
\end{code}

907
%************************************************************************
908
909
910
%*                                                                      *
                        Types
%*                                                                      *
911
912
913
914
%************************************************************************

\begin{code}
tcIfaceType :: IfaceType -> IfL Type
915
916
917
918
919
920
921
tcIfaceType (IfaceTyVar n)         = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2)     = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceType (IfaceLitTy l)         = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
tcIfaceType (IfaceFunTy t1 t2)     = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
                                        ; tks' <- tcIfaceTcArgs (tyConKind tc') tks 
                                        ; return (mkTyConApp tc' tks') }
922
923
tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }

Ian Lynagh's avatar
Ian Lynagh committed
924
tcIfaceTypes :: [IfaceType] -> IfL [Type]
925
926
tcIfaceTypes tys = mapM tcIfaceType tys

927
928
929
930
931
932
933
934
935
936
tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type]
tcIfaceTcArgs _ [] 
  = return []
tcIfaceTcArgs kind (tk:tks)
  = case splitForAllTy_maybe kind of
      Nothing         -> tcIfaceTypes (tk:tks)
      Just (_, kind') -> do { k'   <- tcIfaceKind tk
                            ; tks' <- tcIfaceTcArgs kind' tks
                            ; return (k':tks') }
  
937
938
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
batterseapower's avatar
batterseapower committed
939
tcIfaceCtxt sts = mapM tcIfaceType sts
940
941
942

-----------------------------------------
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
943
944
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
945
946
947
948
949
950
951
952
953
954
955
956

-----------------------------------------
tcIfaceKind :: IfaceKind -> IfL Kind   -- See Note [Checking IfaceTypes vs IfaceKinds]
tcIfaceKind (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceKind (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
tcIfaceKind (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') }
tcIfaceKind (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') }
tcIfaceKind t                     = pprPanic "tcIfaceKind" (ppr t)  -- IfaceCoApp, IfaceLitTy

tcIfaceKinds :: [IfaceKind] -> IfL [Kind]
tcIfaceKinds tys = mapM tcIfaceKind tys
957
958
\end{code}

959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
Note [Checking IfaceTypes vs IfaceKinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to know whether we are checking a *type* or a *kind*.
Consider   module M where
             Proxy :: forall k. k -> *
             data T = T
and consider the two IfaceTypes
      M.Proxy * M.T{tc}
      M.Proxy 'M.T{tc} 'M.T(d}
The first is conventional, but in the latter we use the promoted
type constructor (as a kind) and data constructor (as a type).  However, 
the Name of the promoted type constructor is just M.T; it's the *same name*
as the ordinary type constructor.  

We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy.
Instead we use context to distinguish, as in the source language.  
  - When checking a kind, we look up M.T{tc} and promote it
  - When checking a type, we look up M.T{tc} and don't promote it
                                 and M.T{d}  and promote it
    See tcIfaceKindCon and tcIfaceKTyCon respectively

This context business is why we need tcIfaceTcArgs.


983
%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
984
985
986
%*                                                                      *
                        Coercions
%*                                                                      *
987
988
989
%************************************************************************

\begin{code}
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo (IfaceReflCo r t)         = mkReflCo r <$> tcIfaceType t
tcIfaceCo (IfaceFunCo r c1 c2)      = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2
tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc
                                                     <*> mapM tcIfaceCo cs
tcIfaceCo (IfaceAppCo c1 c2)        = mkAppCo <$> tcIfaceCo c1
                                              <*> tcIfaceCo c2
tcIfaceCo (IfaceForAllCo tv c)      = bindIfaceTyVar tv $ \ tv' ->
                                      mkForAllCo tv' <$> tcIfaceCo c
tcIfaceCo (IfaceCoVarCo n)          = mkCoVarCo <$> tcIfaceCoVar n
tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n
                                                  <*> pure i
                                                  <*> mapM tcIfaceCo cs
tcIfaceCo (IfaceUnivCo r t1 t2)     = UnivCo r <$> tcIfaceType t1
                                               <*> tcIfaceType t2
tcIfaceCo (IfaceSymCo c)            = SymCo    <$> tcIfaceCo c
tcIfaceCo (IfaceTransCo c1 c2)      = TransCo  <$> tcIfaceCo c1
                                               <*> tcIfaceCo c2
tcIfaceCo (IfaceInstCo c1 t2)       = InstCo   <$> tcIfaceCo c1
                                               <*> tcIfaceType t2
tcIfaceCo (IfaceNthCo d c)          = NthCo d  <$> tcIfaceCo c
tcIfaceCo (IfaceLRCo lr c)          = LRCo lr  <$> tcIfaceCo c
tcIfaceCo (IfaceSubCo c)            = SubCo    <$> tcIfaceCo c
1013
1014
1015

tcIfaceCoVar :: FastString -> IfL CoVar
tcIfaceCoVar = tcIfaceLclId
1016
1017
1018
1019
\end{code}


%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1020
1021
1022
%*                                                                      *
                        Core
%*                                                                      *
1023
1024
1025
1026
1027
%************************************************************************

\begin{code}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
tcIfaceExpr (IfaceType ty)
1028
  = Type <$> tcIfaceType ty
1029

1030
1031
1032
1033
1034
1035
tcIfaceExpr (IfaceCo co)
  = Coercion <$> tcIfaceCo co

tcIfaceExpr (IfaceCast expr co)
  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co

1036
tcIfaceExpr (IfaceLcl name)
1037
  = Var <$> tcIfaceLclId name
1038
1039

tcIfaceExpr (IfaceExt gbl)
1040
  = Var <$> tcIfaceExtId gbl
1041
1042

tcIfaceExpr (IfaceLit lit)
1043
1044
  = do lit' <- tcIfaceLit lit
       return (Lit lit')
1045
 
1046
1047
1048
tcIfaceExpr (IfaceFCall cc ty) = do
    ty' <- tcIfaceType ty
    u <- newUnique
Ian Lynagh's avatar
Ian Lynagh committed
1049
1050
    dflags <- getDynFlags
    return (Var (mkFCallId dflags u cc ty'))
1051
1052
1053
1054
1055
1056

tcIfaceExpr (IfaceTuple boxity args)  = do
    args' <- mapM tcIfaceExpr args
    -- Put the missing type arguments back in
    let con_args = map (Type . exprType) args' ++ args'
    return (mkApps (Var con_id) con_args)
1057
1058
1059
1060
1061
1062
  where
    arity = length args
    con_id = dataConWorkId (tupleCon boxity arity)
    

tcIfaceExpr (IfaceLam bndr body)
1063
1064
  = bindIfaceBndr bndr $ \bndr' ->
    Lam bndr' <$> tcIfaceExpr body
1065
1066

tcIfaceExpr (IfaceApp fun arg)
1067
  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
1068

1069
1070
1071
1072
1073
tcIfaceExpr (IfaceECase scrut ty) 
  = do { scrut' <- tcIfaceExpr scrut 
       ; ty' <- tcIfaceType ty
       ; return (castBottomExpr scrut' ty') }

1074
tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
1075
1076
    scrut' <- tcIfaceExpr scrut
    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
1077
    let
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1078
1079
1080
        scrut_ty   = exprType scrut'
        case_bndr' = mkLocalId case_bndr_name scrut_ty
        tc_app     = splitTyConApp scrut_ty
Gabor Greif's avatar
Gabor Greif committed
1081
                -- NB: Won't always succeed (polymorphic case)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1082
1083
1084
1085
                --     but won't be demanded in those cases
                -- NB: not tcSplitTyConApp; we are looking at Core here
                --     look through non-rec newtypes to find the tycon that
                --     corresponds to the datacon in this case alternative
1086

1087
1088
    extendIfaceIdEnv [case_bndr'] $ do
     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
1089
     return (Case scrut' case_bndr' (coreAltsType alts') alts')
1090

1091
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1092
1093
  = do  { name    <- newIfaceName (mkVarOccFS fs)
        ; ty'     <- tcIfaceType ty
1094
1095
        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                              name ty' info
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1096
        ; let id = mkLocalIdWithInfo name ty' id_info
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
        ; rhs' <- tcIfaceExpr rhs
        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
        ; return (Let (NonRec id rhs') body') }

tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
  = do { ids <- mapM tc_rec_bndr (map fst pairs)
       ; extendIfaceIdEnv ids $ do
       { pairs' <- zipWithM tc_pair pairs ids
       ; body' <- tcIfaceExpr body
       ; return (Let (Rec pairs') body') } }
 where
   tc_rec_bndr (IfLetBndr fs ty _) 
     = do { name <- newIfaceName (mkVarOccFS fs)  
          ; ty'  <- tcIfaceType ty
          ; return (mkLocalId name ty') }
   tc_pair (IfLetBndr _ _ info, rhs) id
     = do { rhs' <- tcIfaceExpr rhs
          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                                (idName id) (idType id) info
          ; return (setIdInfo id id_info, rhs') }
1117

1118
tcIfaceExpr (IfaceTick tickish expr) = do
1119
    expr' <- tcIfaceExpr expr
1120
1121
1122
1123
1124
1125
1126
    tickish' <- tcIfaceTickish tickish
    return (Tick tickish' expr')

-------------------------
tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
1127

1128
1129
-------------------------
tcIfaceLit :: Literal -> IfL Literal
1130
1131
-- Integer literals deserialise to (LitInteger i <error thunk>) 
-- so tcIfaceLit just fills in the type.
1132
1133
-- See Note [Integer literals] in Literal
tcIfaceLit (LitInteger i _)
1134
1135
  = do t <- tcIfaceTyCon (IfaceTc integerTyConName)
       return (mkLitInteger i (mkTyConTy t))
1136
1137
tcIfaceLit lit = return lit

1138
-------------------------
Ian Lynagh's avatar
Ian Lynagh committed
1139
1140
1141
tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
           -> (IfaceConAlt, [FastString], IfaceExpr)
           -> IfL (AltCon, [TyVar], CoreExpr)
1142
tcIfaceAlt _ _ (IfaceDefault, names, rhs)
1143
1144
1145
  = ASSERT( null names ) do
    rhs' <- tcIfaceExpr rhs
    return (DEFAULT, [], rhs')
1146
  
1147
tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
1148
  = ASSERT( null names ) do
1149
    lit' <- tcIfaceLit lit
1150
    rhs' <- tcIfaceExpr rhs
1151
    return (LitAlt lit', [], rhs')
1152
1153
1154
1155

-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out.  True enough, but its not that easy!
1156
tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1157
1158
1159
1160
  = do  { con <- tcIfaceDataCon data_occ
        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
        ; tcIfaceDataAlt con inst_tys arg_strs rhs }
batterseapower's avatar
batterseapower committed
1161

Ian Lynagh's avatar
Ian Lynagh committed
1162
1163
tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
               -> IfL (AltCon, [TyVar], CoreExpr)
1164
tcIfaceDataAlt con inst_tys arg_strs rhs
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1165
1166
1167
1168
1169
1170
1171
1172
1173
  = do  { us <- newUniqueSupply
        ; let uniqs = uniqsFromSupply us
        ; let (ex_tvs, arg_ids)
                      = dataConRepFSInstPat arg_strs uniqs con inst_tys

        ; rhs' <- extendIfaceTyVarEnv ex_tvs    $
                  extendIfaceIdEnv arg_ids      $
                  tcIfaceExpr rhs
        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
1174
1175
1176
1177
\end{code}


\begin{code}
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1178
tcExtCoreBindings :: [IfaceBinding] -> IfL CoreProgram  -- Used for external core
1179
1180
tcExtCoreBindings []     = return []
tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
1181

1182
1183
do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
do_one (IfaceNonRec bndr rhs) thing_inside
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1184
1185
1186
1187
1188
  = do  { rhs' <- tcIfaceExpr rhs
        ; bndr' <- newExtCoreBndr bndr
        ; extendIfaceIdEnv [bndr'] $ do 
        { core_binds <- thing_inside
        ; return (NonRec bndr' rhs' : core_binds) }}
1189

1190
do_one (IfaceRec pairs) thing_inside
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1191
1192
1193
1194
1195
  = do  { bndrs' <- mapM newExtCoreBndr bndrs
        ; extendIfaceIdEnv bndrs' $ do
        { rhss' <- mapM tcIfaceExpr rhss
        ; core_binds <- thing_inside
        ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
1196
1197
1198
1199
1200
1201
  where
    (bndrs,rhss) = unzip pairs
\end{code}


%************************************************************************
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1202
1203
1204
%*                                                                      *
                IdInfo
%*                                                                      *
1205
1206
%************************************************************************

1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
Note [wrappers in interface files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to have a nice clever scheme in interface files for
wrappers. A wrapper's unfolding can be reconstructed from its worker's
id and its strictness. This decreased .hi file size (sometimes
significantly, for modules like GHC.Classes with many high-arity w/w
splits) and had a slight corresponding effect on compile times.

However, when we added the second demand analysis, this scheme lead to
some Core lint errors. The second analysis could change the strictness
signatures, which sometimes resulted in a wrapper's regenerated
unfolding applying the wrapper to too many arguments.

Instead of repairing the clever .hi scheme, we abandoned it in favor
of simplicity. The .hi sizes are usually insignificant (excluding the
+1M for base libraries), and compile time barely increases (~+1% for
nofib). The nicer upshot is that unfolding sources no longer include
an Id, so, eg, substitutions need not traverse them any longer.

1226
\begin{code}
1227
1228
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _  IfVanillaId = return VanillaId
1229
1230
tcIdDetails ty (IfDFunId ns)
  = return (DFunId ns (isNewTyCon (classTyCon cls)))
1231
  where
1232
    (_, _, cls, _) = tcSplitDFunTy ty
1233
1234

tcIdDetails _ (IfRecSelId tc naughty)
1235
1236
  = do { tc' <- tcIfaceTyCon tc
       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
1237

1238
1239
1240
1241
tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
tcIdInfo ignore_prags name ty info 
  | ignore_prags = return vanillaIdInfo
  | otherwise    = case info of
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1242
1243
                        NoInfo       -> return vanillaIdInfo
                        HasInfo info -> foldlM tcPrag init_info info
1244
1245
1246
1247
1248
  where
    -- Set the CgInfo to something sensible but uninformative before
    -- we start; default assumption is that it has CAFs
    init_info = vanillaIdInfo

1249
    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
1250
1251
    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
1252
    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
1253
    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
1254

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1255
        -- The next two are lazy, so they don't transitively suck stuff in
1256
1257
    tcPrag info (HsUnfold lb if_unf) 
      = do { unf <- tcUnfolding name ty info if_unf
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1258
1259