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