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