ghc/compiler/iface/TcIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcIfaceSig]{Type checking of type signatures in interface files}
   5
   6 \begin{code}
   7 module TcIface (
   8         tcImportDecl, typecheckIface,
   9         tcIfaceKind, loadImportedInsts, loadImportedRules,
  10         tcExtCoreBindings
  11  ) where
  12 #include "HsVersions.h"
  13
  14 import IfaceSyn
  15 import LoadIface        ( loadHomeInterface, predInstGates )
  16 import IfaceEnv         ( lookupIfaceTop, newGlobalBinder, lookupOrig,
  17                           extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
  18                           tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
  19                           tcIfaceDataCon, tcIfaceLclId,
  20                           newIfaceName, newIfaceNames )
  21 import BuildTyCl        ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
  22 import TcRnMonad
  23 import Type             ( Kind, openTypeKind, liftedTypeKind,
  24                           unliftedTypeKind, mkArrowKind, splitTyConApp,
  25                           mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
  26 import TypeRep          ( Type(..), PredType(..) )
  27 import TyCon            ( TyCon, tyConName )
  28 import HscTypes         ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
  29                           HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
  30                           ModIface(..), ModDetails(..), InstPool, ModGuts,
  31                           TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
  32                           DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
  33 import InstEnv          ( extendInstEnv )
  34 import CoreSyn
  35 import PprType          ( pprClassPred )
  36 import PprCore          ( pprIdRules )
  37 import Rules            ( extendRuleBaseList )
  38 import CoreUtils        ( exprType )
  39 import CoreUnfold
  40 import CoreLint         ( lintUnfolding )
  41 import WorkWrap         ( mkWrapper )
  42 import InstEnv          ( DFunId )
  43 import Id               ( Id, mkVanillaGlobal, mkLocalId )
  44 import MkId             ( mkFCallId )
  45 import IdInfo           ( IdInfo, CafInfo(..), WorkerInfo(..),
  46                           setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo,
  47                           setArityInfo, setInlinePragInfo, setCafInfo,
  48                           vanillaIdInfo, newStrictnessInfo )
  49 import Class            ( Class )
  50 import TyCon            ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
  51 import DataCon          ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
  52 import TysWiredIn       ( tupleCon )
  53 import Var              ( TyVar, mkTyVar, tyVarKind )
  54 import Name             ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName,
  55                           isWiredInName, wiredInNameTyThing_maybe, nameParent )
  56 import NameEnv
  57 import OccName          ( OccName )
  58 import Module           ( Module, ModuleName, moduleName )
  59 import UniqSupply       ( initUs_ )
  60 import Outputable
  61 import SrcLoc           ( noSrcLoc )
  62 import Util             ( zipWithEqual, dropList, equalLength, zipLazy )
  63 import Maybes           ( expectJust )
  64 import CmdLineOpts      ( DynFlag(..) )
  65 \end{code}
  66
  67 This module takes
  68
  69         IfaceDecl -> TyThing
  70         IfaceType -> Type
  71         etc
  72
  73 An IfaceDecl is populated with RdrNames, and these are not renamed to
  74 Names before typechecking, because there should be no scope errors etc.
  75
  76         -- For (b) consider: f = $(...h....)
  77         -- where h is imported, and calls f via an hi-boot file.
  78         -- This is bad!  But it is not seen as a staging error, because h
  79         -- is indeed imported.  We don't want the type-checker to black-hole
  80         -- when simplifying and compiling the splice!
  81         --
  82         -- Simple solution: discard any unfolding that mentions a variable
  83         -- bound in this module (and hence not yet processed).
  84         -- The discarding happens when forkM finds a type error.
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 %*      tcImportDecl is the key function for "faulting in"              *
  89 %*      imported things
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 The main idea is this.  We are chugging along type-checking source code, and
  94 find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
  95 it in the EPS type envt.  So it
  96         1 loads GHC.Base.hi
  97         2 gets the decl for GHC.Base.map
  98         3 typechecks it via tcIfaceDecl
  99         4 and adds it to the type env in the EPS
 100
 101 Note that DURING STEP 4, we may find that map's type mentions a type
 102 constructor that also
 103
 104 Notice that for imported things we read the current version from the EPS
 105 mutable variable.  This is important in situations like
 106         ...$(e1)...$(e2)...
 107 where the code that e1 expands to might import some defns that
 108 also turn out to be needed by the code that e2 expands to.
 109
 110 \begin{code}
 111 tcImportDecl :: Name -> IfG TyThing
 112 -- Get the TyThing for this Name from an interface file
 113 tcImportDecl name
 114   = do  {
 115     -- Make sure the interface is loaded
 116         ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name }
 117         ; traceIf (nd_doc <+> char '{')         -- Brace matches the later message
 118         ; loadHomeInterface nd_doc name
 119
 120     -- Get the real name of the thing, with a correct nameParent field.
 121     -- Before the interface is loaded, we may have a non-committal 'Nothing'
 122     -- in the namePareent field (made up by IfaceEnv.lookupOrig), but
 123     -- loading the interface updates the name cache.
 124     -- We need the right nameParent field in getThing
 125         ; real_name <- lookupOrig (nameModuleName name) (nameOccName name)
 126
 127     -- Get the decl out of the EPS
 128         ; main_thing <- ASSERT( real_name == name )     -- Unique should not change!
 129                         getThing real_name
 130
 131     -- Record the import in the type env,
 132     -- slurp any rules it allows in
 133         ; recordImportOf main_thing
 134
 135         ; let { extra | getName main_thing == real_name = empty
 136                       | otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) }
 137         ; traceIf (ptext SLIT(" ...imported decl for") <+> ppr main_thing <+> extra <+> char '}')
 138
 139
 140     -- Look up the wanted Name in the type envt; it might be
 141     -- one of the subordinate members of the input thing
 142         ; if real_name == getName main_thing
 143           then return main_thing
 144           else do
 145         { eps <- getEps
 146         ; return (expectJust "tcImportDecl" $
 147                   lookupTypeEnv (eps_PTE eps) real_name) }}
 148
 149 recordImportOf :: TyThing -> IfG ()
 150 -- Update the EPS to record the import of the Thing
 151 --   (a) augment the type environment; this is done even for wired-in
 152 --       things, so that we don't go through this rigmarole a second time
 153 --   (b) slurp in any rules to maintain the invariant that any rule
 154 --           whose gates are all in the type envt, is in eps_rule_base
 155
 156 recordImportOf thing
 157   = do  { new_things <- updateEps (\ eps ->
 158             let { new_things   = thing : implicitTyThings thing
 159                 ; new_type_env = extendTypeEnvList (eps_PTE eps) new_things
 160                 -- NB: opportunity for a very subtle loop here!
 161                 -- If working out what the implicitTyThings are involves poking
 162                 -- any of the fork'd thunks in 'thing', then here's what happens
 163                 --      * recordImportOf succeed, extending type-env with a thunk
 164                 --      * the next guy to pull on type-env forces the thunk
 165                 --      * which pokes the suspended forks
 166                 --      * which, to execute, need to consult type-env (to check
 167                 --        entirely unrelated types, perhaps)
 168             }
 169             in (eps { eps_PTE = new_type_env }, new_things)
 170           )
 171         ; traceIf (text "tcImport: extend type env" <+> ppr new_things)
 172         }
 173
 174 getThing :: Name -> IfG TyThing
 175 -- Find and typecheck the thing; the Name might be a "subordinate name"
 176 -- of the "main thing" (e.g. the constructor of a data type declaration)
 177 -- The Thing we return is the parent "main thing"
 178
 179 getThing name
 180   | Just thing <- wiredInNameTyThing_maybe name
 181    = return thing
 182
 183   | otherwise = do      -- The normal case, not wired in
 184   {     -- Get the decl from the pool
 185     mb_decl <- updateEps (\ eps -> selectDecl eps name)
 186
 187     ; case mb_decl of
 188         Just decl -> initIfaceLcl (nameModuleName name) (tcIfaceDecl decl)
 189                 -- Typecheck it
 190                 -- Side-effects EPS by faulting in any needed decls
 191                 -- (via nested calls to tcImportDecl)
 192
 193
 194         Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
 195                 -- Declaration not found
 196                 -- No errors-var to accumulate errors in, so just
 197                 -- print out the error right now
 198
 199     }
 200   where
 201      msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
 202               2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
 203                        ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
 204
 205 selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl)
 206 -- Use nameParent to get the parent name of the thing
 207 selectDecl eps@(EPS { eps_decls = Pool decls_map n_in n_out}) name
 208    = case lookupNameEnv decls_map main_name of
 209         Nothing   -> (eps, Nothing)
 210         Just decl -> (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl)
 211    where
 212      main_name = nameParent name
 213      decls'    = delFromNameEnv decls_map main_name
 214 \end{code}
 215
 216 %************************************************************************
 217 %*                                                                      *
 218                 Type-checking a complete interface
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 Suppose we discover we don't need to recompile.  Then we must type
 223 check the old interface file.  This is a bit different to the
 224 incremental type checking we do as we suck in interface files.  Instead
 225 we do things similarly as when we are typechecking source decls: we
 226 bring into scope the type envt for the interface all at once, using a
 227 knot.  Remember, the decls aren't necessarily in dependency order --
 228 and even if they were, the type decls might be mutually recursive.
 229
 230 \begin{code}
 231 typecheckIface :: HscEnv
 232                -> ModIface      -- Get the decls from here
 233                -> IO ModDetails
 234 typecheckIface hsc_env iface@(ModIface { mi_module = mod, mi_decls = ver_decls,
 235                                          mi_rules = rules, mi_insts = dfuns })
 236   = initIfaceTc hsc_env iface $ \ tc_env_var -> do
 237         {       -- Typecheck the decls
 238           names <- mappM (lookupOrig (moduleName mod) . ifName) decls
 239         ; ty_things <- fixM (\ rec_ty_things -> do
 240                 { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
 241                         -- This only makes available the "main" things,
 242                         -- but that's enough for the strictly-checked part
 243                 ; mapM tcIfaceDecl decls })
 244
 245                 -- Now augment the type envt with all the implicit things
 246                 -- These will be needed when type-checking the unfoldings for
 247                 -- the IfaceIds, but this is done lazily, so writing the thing
 248                 -- now is sufficient
 249         ; let   { add_implicits main_thing = main_thing : implicitTyThings main_thing
 250                 ; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
 251         ; writeMutVar tc_env_var type_env
 252
 253                 -- Now do those rules and instances
 254         ; dfuns <- mapM tcIfaceInst (mi_insts iface)
 255         ; rules <- mapM tcIfaceRule (mi_rules iface)
 256
 257                 -- Finished
 258         ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
 259     }
 260   where
 261     decls = map snd ver_decls
 262 \end{code}
 263
 264
 265 %************************************************************************
 266 %*                                                                      *
 267                 Type and class declarations
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 When typechecking a data type decl, we *lazily* (via forkM) typecheck
 272 the constructor argument types.  This is in the hope that we may never
 273 poke on those argument types, and hence may never need to load the
 274 interface files for types mentioned in the arg types.
 275
 276 E.g.
 277         data Foo.S = MkS Baz.T
 278 Mabye we can get away without even loading the interface for Baz!
 279
 280 This is not just a performance thing.  Suppose we have
 281         data Foo.S = MkS Baz.T
 282         data Baz.T = MkT Foo.S
 283 (in different interface files, of course).
 284 Now, first we load and typecheck Foo.S, and add it to the type envt.
 285 If we do explore MkS's argument, we'll load and typecheck Baz.T.
 286 If we explore MkT's argument we'll find Foo.S already in the envt.
 287
 288 If we typechecked constructor args eagerly, when loading Foo.S we'd try to
 289 typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
 290 which isn't done yet.
 291
 292 All very cunning. However, there is a rather subtle gotcha which bit
 293 me when developing this stuff.  When we typecheck the decl for S, we
 294 extend the type envt with S, MkS, and all its implicit Ids.  Suppose
 295 (a bug, but it happened) that the list of implicit Ids depended in
 296 turn on the constructor arg types.  Then the following sequence of
 297 events takes place:
 298         * we build a thunk <t> for the constructor arg tys
 299         * we build a thunk for the extended type environment (depends on <t>)
 300         * we write the extended type envt into the global EPS mutvar
 301
 302 Now we look something up in the type envt
 303         * that pulls on <t>
 304         * which reads the global type envt out of the global EPS mutvar
 305         * but that depends in turn on <t>
 306
 307 It's subtle, because, it'd work fine if we typechecked the constructor args
 308 eagerly -- they don't need the extended type envt.  They just get the extended
 309 type envt by accident, because they look at it later.
 310
 311 What this means is that the implicitTyThings MUST NOT DEPEND on any of
 312 the forkM stuff.
 313
 314
 315 \begin{code}
 316 tcIfaceDecl :: IfaceDecl -> IfL TyThing
 317
 318 tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
 319   = do  { name <- lookupIfaceTop occ_name
 320         ; ty <- tcIfaceType iface_type
 321         ; info <- tcIdInfo name ty info
 322         ; return (AnId (mkVanillaGlobal name ty info)) }
 323
 324 tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name,
 325                         ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
 326                         ifCons = rdr_cons,
 327                         ifVrcs = arg_vrcs, ifRec = is_rec,
 328                         ifGeneric = want_generic })
 329   = do  { tc_name <- lookupIfaceTop occ_name
 330         ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 331
 332         { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt)
 333
 334         ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $
 335                      tcIfaceCtxt rdr_ctxt
 336                 -- The reason for laziness here is to postpone
 337                 -- looking at the context, because the class may not
 338                 -- be in the type envt yet.  E.g.
 339                 --      class Real a where { toRat :: a -> Ratio Integer }
 340                 --      data (Real a) => Ratio a = ...
 341                 -- We suck in the decl for Real, and type check it, which sucks
 342                 -- in the data type Ratio; but we must postpone typechecking the
 343                 -- context
 344
 345         ; tycon <- fixM ( \ tycon -> do
 346             { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
 347             ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons
 348                             arg_vrcs is_rec want_generic
 349             ; return tycon
 350             })
 351         ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
 352         ; return (ATyCon tycon)
 353     } }
 354
 355 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
 356                        ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
 357    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 358      { tc_name <- lookupIfaceTop occ_name
 359      ; rhs_ty <- tcIfaceType rdr_rhs_ty
 360      ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
 361      }
 362
 363 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
 364                          ifFDs = rdr_fds, ifSigs = rdr_sigs,
 365                          ifVrcs = tc_vrcs, ifRec = tc_isrec })
 366   = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 367     { cls_name <- lookupIfaceTop occ_name
 368     ; ctxt <- tcIfaceCtxt rdr_ctxt
 369     ; sigs <- mappM tc_sig rdr_sigs
 370     ; fds  <- mappM tc_fd rdr_fds
 371     ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
 372     ; return (AClass cls) }
 373   where
 374    tc_sig (IfaceClassOp occ dm rdr_ty)
 375      = do { op_name <- lookupIfaceTop occ
 376           ; op_ty   <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
 377                 -- Must be done lazily for just the same reason as the
 378                 -- context of a data decl: the type sig might mention the
 379                 -- class being defined
 380           ; return (op_name, dm, op_ty) }
 381
 382    mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty]
 383
 384    tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1
 385                            ; tvs2' <- mappM tcIfaceTyVar tvs2
 386                            ; return (tvs1', tvs2') }
 387
 388 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
 389   = do  { name <- lookupIfaceTop rdr_name
 390         ; return (ATyCon (mkForeignTyCon name ext_name
 391                                          liftedTypeKind 0 [])) }
 392
 393 tcIfaceDataCons tycon tyvars ctxt Unknown
 394   = returnM Unknown
 395
 396 tcIfaceDataCons tycon tyvars ctxt (DataCons cs)
 397   = mappM tc_con_decl cs        `thenM` \ data_cons ->
 398     returnM (DataCons data_cons)
 399   where
 400     tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls)
 401       = bindIfaceTyVars ex_tvs  $ \ ex_tyvars -> do
 402         { name <- lookupIfaceTop occ
 403         ; ex_theta <- tcIfaceCtxt ex_ctxt       -- Laziness seems not worth the bother here
 404
 405         -- Read the argument types, but lazily to avoid faulting in
 406         -- the component types unless they are really needed
 407         ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ;
 408
 409         ; lbl_names <- mappM lookupIfaceTop field_lbls
 410
 411         ; buildDataCon name stricts lbl_names
 412                        tyvars ctxt ex_tyvars ex_theta
 413                        arg_tys tycon
 414         }
 415     mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args]
 416 \end{code}
 417
 418
 419 %************************************************************************
 420 %*                                                                      *
 421                 Instances
 422 %*                                                                      *
 423 %************************************************************************
 424
 425 The gating story for instance declarations
 426 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 427 When we are looking for a dict (C t1..tn), we slurp in instance decls for
 428 C that
 429         mention at least one of the type constructors
 430         at the roots of t1..tn
 431
 432 Why "at least one" rather than "all"?  Because functional dependencies
 433 complicate the picture.  Consider
 434         class C a b | a->b where ...
 435         instance C Foo Baz where ...
 436 Here, the gates are really only C and Foo, *not* Baz.
 437 That is, if C and Foo are visible, even if Baz isn't, we must
 438 slurp the decl, even if Baz is thus far completely unknown to the
 439 system.
 440
 441 Why "roots of the types"?  Reason is overlap.  For example, suppose there
 442 are interfaces in the pool for
 443   (a)   C Int b
 444  (b)    C a [b]
 445   (c)   C a [T]
 446 Then, if we are trying to resolve (C Int x), we need (a)
 447 if we are trying to resolve (C x [y]), we need *both* (b) and (c),
 448 even though T is not involved yet, so that we spot the overlap.
 449
 450 \begin{code}
 451 loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv
 452 loadImportedInsts cls tys
 453   = do  {       -- Get interfaces for wired-in things, such as Integer
 454                 -- Any non-wired-in tycons will already be loaded, else
 455                 -- we couldn't have them in the Type
 456         ; this_mod <- getModule
 457         ; let { (cls_gate, tc_gates) = predInstGates cls tys
 458               ; imp_wi n = isWiredInName n && this_mod /= nameModule n
 459               ; wired_tcs = filter imp_wi tc_gates }
 460                         -- Wired-in tycons not from this module.  The "this-module"
 461                         -- test bites only when compiling Base etc, because loadHomeInterface
 462                         -- barfs if it's asked to load a non-existent interface
 463         ; if null wired_tcs then returnM ()
 464           else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
 465
 466         ; eps_var <- getEpsVar
 467         ; eps <- readMutVar eps_var
 468
 469         -- Suck in the instances
 470         ; let { (inst_pool', iface_insts)
 471                     = selectInsts (eps_insts eps) cls_gate tc_gates }
 472
 473         -- Empty => finish up rapidly, without writing to eps
 474         ; if null iface_insts then
 475                 return (eps_inst_env eps)
 476           else do
 477         { writeMutVar eps_var (eps {eps_insts = inst_pool'})
 478
 479         ; traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
 480                         nest 2 (vcat (map ppr iface_insts))])
 481
 482         -- Typecheck the new instances
 483         ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
 484
 485         -- And put them in the package instance environment
 486         ; updateEps ( \ eps ->
 487             let
 488                 inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns
 489             in
 490             (eps { eps_inst_env = inst_env' }, inst_env')
 491         )}}
 492   where
 493     wired_doc = ptext SLIT("Need home inteface for wired-in thing")
 494
 495 tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst)
 496
 497 tcIfaceInst :: IfaceInst -> IfL DFunId
 498 tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
 499   = tcIfaceExtId (LocalTop dfun_occ)
 500
 501 selectInsts :: InstPool -> Name -> [Name] -> (InstPool, [(ModuleName, IfaceInst)])
 502 selectInsts pool@(Pool insts n_in n_out) cls tycons
 503   = (Pool insts' n_in (n_out + length iface_insts), iface_insts)
 504   where
 505     (insts', iface_insts)
 506         = case lookupNameEnv insts cls of {
 507                 Nothing -> (insts, []) ;
 508                 Just gated_insts ->
 509
 510           case foldl choose ([],[]) gated_insts of {
 511             (_, []) -> (insts, []) ;    -- None picked
 512             (gated_insts', iface_insts') ->
 513
 514           (extendNameEnv insts cls gated_insts', iface_insts') }}
 515
 516         -- Reverses the gated decls, but that doesn't matter
 517     choose (gis, decls) (gates, decl)
 518         | any (`elem` tycons) gates = (gis,                decl:decls)
 519         | otherwise                 = ((gates,decl) : gis, decls)
 520 \end{code}
 521
 522 %************************************************************************
 523 %*                                                                      *
 524                 Rules
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
 529 are in the type environment.  However, remember that typechecking a Rule may
 530 (as a side effect) augment the type envt, and so we may need to iterate the process.
 531
 532 \begin{code}
 533 loadImportedRules :: HscEnv -> ModGuts -> IO PackageRuleBase
 534 loadImportedRules hsc_env guts
 535   = initIfaceRules hsc_env guts $ do
 536         { -- Get new rules
 537           if_rules <- updateEps (\ eps ->
 538                 let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) }
 539                 in (eps { eps_rules = new_pool }, if_rules) )
 540
 541         ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
 542
 543         ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
 544         ; core_rules <- mapM tc_rule if_rules
 545
 546         -- Debug print
 547         ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
 548
 549         -- Update the rule base and return it
 550         ; updateEps (\ eps ->
 551             let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
 552             in (eps { eps_rule_base = new_rule_base }, new_rule_base)
 553           )
 554
 555         -- Strictly speaking, at this point we should go round again, since
 556         -- typechecking one set of rules may bring in new things which enable
 557         -- some more rules to come in.  But we call loadImportedRules several
 558         -- times anyway, so I'm going to be lazy and ignore this.
 559     }
 560
 561
 562 selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, IfaceRule)])
 563 -- Not terribly efficient.  Look at each rule in the pool to see if
 564 -- all its gates are in the type env.  If so, take it out of the pool.
 565 -- If not, trim its gates for next time.
 566 selectRules (Pool rules n_in n_out) type_env
 567   = (Pool rules' n_in (n_out + length if_rules), if_rules)
 568   where
 569     (rules', if_rules) = foldl do_one ([], []) rules
 570
 571     do_one (pool, if_rules) (gates, rule)
 572         | null gates' = (pool, rule:if_rules)
 573         | otherwise   = ((gates',rule) : pool, if_rules)
 574         where
 575           gates' = filter (`elemNameEnv` type_env) gates
 576
 577
 578 tcIfaceRule :: IfaceRule -> IfL IdCoreRule
 579 tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
 580                         ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
 581   = bindIfaceBndrs bndrs        $ \ bndrs' ->
 582     do  { fn <- tcIfaceExtId fn_rdr
 583         ; args' <- mappM tcIfaceExpr args
 584         ; rhs'  <- tcIfaceExpr rhs
 585         ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) }
 586
 587 tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
 588   = do  { fn <- tcIfaceExtId fn_rdr
 589         ; returnM (fn, core_rule) }
 590 \end{code}
 591
 592
 593 %************************************************************************
 594 %*                                                                      *
 595                         Types
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 tcIfaceKind :: IfaceKind -> Kind
 601 tcIfaceKind IfaceOpenTypeKind     = openTypeKind
 602 tcIfaceKind IfaceLiftedTypeKind   = liftedTypeKind
 603 tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind
 604 tcIfaceKind (IfaceFunKind k1 k2)  = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2)
 605
 606 -----------------------------------------
 607 tcIfaceType :: IfaceType -> IfL Type
 608 tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
 609 tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
 610 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 611 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') }
 612 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
 613 tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }
 614
 615 tcIfaceTypes tys = mapM tcIfaceType tys
 616
 617 -----------------------------------------
 618 tcIfacePredType :: IfacePredType -> IfL PredType
 619 tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
 620 tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
 621
 622 -----------------------------------------
 623 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
 624 tcIfaceCtxt sts = mappM tcIfacePredType sts
 625 \end{code}
 626
 627
 628 %************************************************************************
 629 %*                                                                      *
 630                         Core
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 \begin{code}
 635 tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
 636 tcIfaceExpr (IfaceType ty)
 637   = tcIfaceType ty              `thenM` \ ty' ->
 638     returnM (Type ty')
 639
 640 tcIfaceExpr (IfaceLcl name)
 641   = tcIfaceLclId name   `thenM` \ id ->
 642     returnM (Var id)
 643
 644 tcIfaceExpr (IfaceExt gbl)
 645   = tcIfaceExtId gbl    `thenM` \ id ->
 646     returnM (Var id)
 647
 648 tcIfaceExpr (IfaceLit lit)
 649   = returnM (Lit lit)
 650
 651 tcIfaceExpr (IfaceFCall cc ty)
 652   = tcIfaceType ty      `thenM` \ ty' ->
 653     newUnique           `thenM` \ u ->
 654     returnM (Var (mkFCallId u cc ty'))
 655
 656 tcIfaceExpr (IfaceTuple boxity args)
 657   = mappM tcIfaceExpr args      `thenM` \ args' ->
 658     let
 659         -- Put the missing type arguments back in
 660         con_args = map (Type . exprType) args' ++ args'
 661     in
 662     returnM (mkApps (Var con_id) con_args)
 663   where
 664     arity = length args
 665     con_id = dataConWorkId (tupleCon boxity arity)
 666
 667
 668 tcIfaceExpr (IfaceLam bndr body)
 669   = bindIfaceBndr bndr          $ \ bndr' ->
 670     tcIfaceExpr body            `thenM` \ body' ->
 671     returnM (Lam bndr' body')
 672
 673 tcIfaceExpr (IfaceApp fun arg)
 674   = tcIfaceExpr fun             `thenM` \ fun' ->
 675     tcIfaceExpr arg             `thenM` \ arg' ->
 676     returnM (App fun' arg')
 677
 678 tcIfaceExpr (IfaceCase scrut case_bndr alts)
 679   = tcIfaceExpr scrut           `thenM` \ scrut' ->
 680     newIfaceName case_bndr      `thenM` \ case_bndr_name ->
 681     let
 682         scrut_ty   = exprType scrut'
 683         case_bndr' = mkLocalId case_bndr_name scrut_ty
 684         tc_app     = splitTyConApp scrut_ty
 685                 -- NB: Won't always succeed (polymoprhic case)
 686                 --     but won't be demanded in those cases
 687                 -- NB: not tcSplitTyConApp; we are looking at Core here
 688                 --     look through non-rec newtypes to find the tycon that
 689                 --     corresponds to the datacon in this case alternative
 690     in
 691     extendIfaceIdEnv [case_bndr']       $
 692     mappM (tcIfaceAlt tc_app) alts      `thenM` \ alts' ->
 693     returnM (Case scrut' case_bndr' alts')
 694
 695 tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
 696   = tcIfaceExpr rhs             `thenM` \ rhs' ->
 697     bindIfaceId bndr            $ \ bndr' ->
 698     tcIfaceExpr body            `thenM` \ body' ->
 699     returnM (Let (NonRec bndr' rhs') body')
 700
 701 tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
 702   = bindIfaceIds bndrs          $ \ bndrs' ->
 703     mappM tcIfaceExpr rhss      `thenM` \ rhss' ->
 704     tcIfaceExpr body            `thenM` \ body' ->
 705     returnM (Let (Rec (bndrs' `zip` rhss')) body')
 706   where
 707     (bndrs, rhss) = unzip pairs
 708
 709 tcIfaceExpr (IfaceNote note expr)
 710   = tcIfaceExpr expr            `thenM` \ expr' ->
 711     case note of
 712         IfaceCoerce to_ty -> tcIfaceType to_ty  `thenM` \ to_ty' ->
 713                              returnM (Note (Coerce to_ty'
 714                                                    (exprType expr')) expr')
 715         IfaceInlineCall   -> returnM (Note InlineCall expr')
 716         IfaceInlineMe     -> returnM (Note InlineMe   expr')
 717         IfaceSCC cc       -> returnM (Note (SCC cc)   expr')
 718         IfaceCoreNote n   -> returnM (Note (CoreNote n) expr')
 719
 720 -------------------------
 721 tcIfaceAlt _ (IfaceDefault, names, rhs)
 722   = ASSERT( null names )
 723     tcIfaceExpr rhs             `thenM` \ rhs' ->
 724     returnM (DEFAULT, [], rhs')
 725
 726 tcIfaceAlt _ (IfaceLitAlt lit, names, rhs)
 727   = ASSERT( null names )
 728     tcIfaceExpr rhs             `thenM` \ rhs' ->
 729     returnM (LitAlt lit, [], rhs')
 730
 731 -- A case alternative is made quite a bit more complicated
 732 -- by the fact that we omit type annotations because we can
 733 -- work them out.  True enough, but its not that easy!
 734 tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
 735   = let
 736         tycon_mod = nameModuleName (tyConName tycon)
 737     in
 738     tcIfaceDataCon (ExtPkg tycon_mod data_occ)  `thenM` \ con ->
 739     newIfaceNames arg_occs                      `thenM` \ arg_names ->
 740     let
 741         ex_tyvars   = dataConExistentialTyVars con
 742         main_tyvars = tyConTyVars tycon
 743         ex_tyvars'  = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars]
 744         ex_tys'     = mkTyVarTys ex_tyvars'
 745         arg_tys     = dataConArgTys con (inst_tys ++ ex_tys')
 746         id_names    = dropList ex_tyvars arg_names
 747         arg_ids
 748 #ifdef DEBUG
 749                 | not (equalLength id_names arg_tys)
 750                 = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$
 751                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 752                                          ppr arg_tys)
 753                 | otherwise
 754 #endif
 755                 = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys
 756     in
 757     ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars,
 758              ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$  ppr main_tyvars  )
 759     extendIfaceTyVarEnv ex_tyvars'      $
 760     extendIfaceIdEnv arg_ids            $
 761     tcIfaceExpr rhs                     `thenM` \ rhs' ->
 762     returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 763
 764 tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
 765   = newIfaceNames arg_occs      `thenM` \ arg_names ->
 766     let
 767         [con]   = tyConDataCons tycon
 768         arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys
 769     in
 770     ASSERT( isTupleTyCon tycon )
 771     extendIfaceIdEnv arg_ids            $
 772     tcIfaceExpr rhs                     `thenM` \ rhs' ->
 773     returnM (DataAlt con, arg_ids, rhs')
 774 \end{code}
 775
 776
 777 \begin{code}
 778 tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core
 779 tcExtCoreBindings mod []     = return []
 780 tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs)
 781
 782 do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
 783 do_one mod (IfaceNonRec bndr rhs) thing_inside
 784   = do  { rhs' <- tcIfaceExpr rhs
 785         ; bndr' <- newExtCoreBndr mod bndr
 786         ; extendIfaceIdEnv [bndr'] $ do
 787         { core_binds <- thing_inside
 788         ; return (NonRec bndr' rhs' : core_binds) }}
 789
 790 do_one mod (IfaceRec pairs) thing_inside
 791   = do  { bndrs' <- mappM (newExtCoreBndr mod) bndrs
 792         ; extendIfaceIdEnv bndrs' $ do
 793         { rhss' <- mappM tcIfaceExpr rhss
 794         ; core_binds <- thing_inside
 795         ; return (Rec (bndrs' `zip` rhss') : core_binds) }}
 796   where
 797     (bndrs,rhss) = unzip pairs
 798 \end{code}
 799
 800
 801 %************************************************************************
 802 %*                                                                      *
 803                 IdInfo
 804 %*                                                                      *
 805 %************************************************************************
 806
 807 \begin{code}
 808 tcIdInfo name ty NoInfo        = return vanillaIdInfo
 809 tcIdInfo name ty DiscardedInfo = return vanillaIdInfo
 810 tcIdInfo name ty (HasInfo iface_info)
 811   = foldlM tcPrag init_info iface_info
 812   where
 813     -- Set the CgInfo to something sensible but uninformative before
 814     -- we start; default assumption is that it has CAFs
 815     init_info = vanillaIdInfo
 816
 817     tcPrag info HsNoCafRefs         = returnM (info `setCafInfo`   NoCafRefs)
 818     tcPrag info (HsArity arity)     = returnM (info `setArityInfo` arity)
 819     tcPrag info (HsStrictness str)  = returnM (info `setAllStrictnessInfo` Just str)
 820
 821         -- The next two are lazy, so they don't transitively suck stuff in
 822     tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
 823     tcPrag info (HsUnfold inline_prag expr)
 824         = tcPragExpr name expr  `thenM` \ maybe_expr' ->
 825           let
 826                 -- maybe_expr' doesn't get looked at if the unfolding
 827                 -- is never inspected; so the typecheck doesn't even happen
 828                 unfold_info = case maybe_expr' of
 829                                 Nothing    -> noUnfolding
 830                                 Just expr' -> mkTopUnfolding expr'
 831           in
 832           returnM (info `setUnfoldingInfoLazily` unfold_info
 833                         `setInlinePragInfo`      inline_prag)
 834 \end{code}
 835
 836 \begin{code}
 837 tcWorkerInfo ty info wkr_name arity
 838   = do  { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId (LocalTop wkr_name))
 839
 840         -- We return without testing maybe_wkr_id, but as soon as info is
 841         -- looked at we will test it.  That's ok, because its outside the
 842         -- knot; and there seems no big reason to further defer the
 843         -- tcIfaceId lookup.  (Contrast with tcPragExpr, where postponing walking
 844         -- over the unfolding until it's actually used does seem worth while.)
 845         ; us <- newUniqueSupply
 846
 847         ; returnM (case mb_wkr_id of
 848                      Nothing     -> info
 849                      Just wkr_id -> add_wkr_info us wkr_id info) }
 850   where
 851     doc = text "Worker for" <+> ppr wkr_name
 852     add_wkr_info us wkr_id info
 853         = info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
 854                `setWorkerInfo`           HasWorker wkr_id arity
 855
 856     mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
 857
 858         -- We are relying here on strictness info always appearing
 859         -- before worker info,  fingers crossed ....
 860     strict_sig = case newStrictnessInfo info of
 861                    Just sig -> sig
 862                    Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr_name)
 863 \end{code}
 864
 865 For unfoldings we try to do the job lazily, so that we never type check
 866 an unfolding that isn't going to be looked at.
 867
 868 \begin{code}
 869 tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
 870 tcPragExpr name expr
 871   = forkM_maybe doc $
 872     tcIfaceExpr expr            `thenM` \ core_expr' ->
 873
 874                 -- Check for type consistency in the unfolding
 875     ifOptM Opt_DoCoreLinting (
 876         get_in_scope_ids                        `thenM` \ in_scope ->
 877         case lintUnfolding noSrcLoc in_scope core_expr' of
 878           Nothing       -> returnM ()
 879           Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
 880     )                           `thenM_`
 881
 882    returnM core_expr'
 883   where
 884     doc = text "Unfolding of" <+> ppr name
 885     get_in_scope_ids    -- Urgh; but just for linting
 886         = setLclEnv () $
 887           do    { env <- getGblEnv
 888                 ; case if_rec_types env of {
 889                           Nothing -> return [] ;
 890                           Just (_, get_env) -> do
 891                 { type_env <- get_env
 892                 ; return (typeEnvIds type_env) }}}
 893 \end{code}
 894
 895
 896
 897 %************************************************************************
 898 %*                                                                      *
 899                 Bindings
 900 %*                                                                      *
 901 %************************************************************************
 902
 903 \begin{code}
 904 bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
 905 bindIfaceBndr (IfaceIdBndr bndr) thing_inside
 906   = bindIfaceId bndr thing_inside
 907 bindIfaceBndr (IfaceTvBndr bndr) thing_inside
 908   = bindIfaceTyVar bndr thing_inside
 909
 910 bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
 911 bindIfaceBndrs []     thing_inside = thing_inside []
 912 bindIfaceBndrs (b:bs) thing_inside
 913   = bindIfaceBndr b     $ \ b' ->
 914     bindIfaceBndrs bs   $ \ bs' ->
 915     thing_inside (b':bs')
 916
 917 -----------------------
 918 bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a
 919 bindIfaceId (occ, ty) thing_inside
 920   = do  { name <- newIfaceName occ
 921         ; ty' <- tcIfaceType ty
 922         ; let { id = mkLocalId name ty' }
 923         ; extendIfaceIdEnv [id] (thing_inside id) }
 924
 925 bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a
 926 bindIfaceIds bndrs thing_inside
 927   = do  { names <- newIfaceNames occs
 928         ; tys' <- mappM tcIfaceType tys
 929         ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' }
 930         ; extendIfaceIdEnv ids (thing_inside ids) }
 931   where
 932     (occs,tys) = unzip bndrs
 933
 934
 935 -----------------------
 936 newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id
 937 newExtCoreBndr mod (occ, ty)
 938   = do  { name <- newGlobalBinder mod occ Nothing noSrcLoc
 939         ; ty' <- tcIfaceType ty
 940         ; return (mkLocalId name ty') }
 941
 942 -----------------------
 943 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 944 bindIfaceTyVar (occ,kind) thing_inside
 945   = do  { name <- newIfaceName occ
 946         ; let tyvar = mk_iface_tyvar name kind
 947         ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 948
 949 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 950 bindIfaceTyVars bndrs thing_inside
 951   = do  { names <- newIfaceNames occs
 952         ; let tyvars = zipWith mk_iface_tyvar names kinds
 953         ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
 954   where
 955     (occs,kinds) = unzip bndrs
 956
 957 mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
 958 \end{code}