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