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