ghc/compiler/iface/TcIface.lhs

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