ghc/compiler/typecheck/TcIfaceSig.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 TcIfaceSig ( tcInterfaceSigs,
   8                     tcCoreExpr,
   9                     tcCoreLamBndrs,
  10                     tcCoreBinds ) where
  11
  12 #include "HsVersions.h"
  13
  14 import HsSyn            ( CoreDecl(..), TyClDecl(..), HsTupCon(..) )
  15 import TcHsSyn          ( TypecheckedCoreBind )
  16 import TcRnTypes
  17 import TcRnMonad
  18 import TcMonoType       ( tcIfaceType, kcHsSigType )
  19 import TcEnv            ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId,
  20                           tcLookupDataCon )
  21
  22 import RnHsSyn          ( RenamedCoreDecl, RenamedTyClDecl )
  23 import HsCore
  24 import Literal          ( Literal(..) )
  25 import CoreSyn
  26 import CoreUtils        ( exprType )
  27 import CoreUnfold
  28 import CoreLint         ( lintUnfolding )
  29 import WorkWrap         ( mkWrapper )
  30
  31 import Id               ( Id, mkVanillaGlobal, mkLocalId )
  32 import MkId             ( mkFCallId )
  33 import IdInfo
  34 import TyCon            ( tyConDataCons, tyConTyVars )
  35 import DataCon          ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
  36 import Type             ( mkTyVarTys, splitTyConApp )
  37 import TysWiredIn       ( tupleCon )
  38 import Var              ( mkTyVar, tyVarKind )
  39 import Name             ( Name )
  40 import UniqSupply       ( initUs_ )
  41 import Outputable
  42 import Util             ( zipWithEqual, dropList, equalLength )
  43 import HscTypes         ( typeEnvIds )
  44 import CmdLineOpts      ( DynFlag(..) )
  45 \end{code}
  46
  47 Ultimately, type signatures in interfaces will have pragmatic
  48 information attached, so it is a good idea to have separate code to
  49 check them.
  50
  51 As always, we do not have to worry about user-pragmas in interface
  52 signatures.
  53
  54 \begin{code}
  55 tcInterfaceSigs :: [RenamedTyClDecl]    -- Ignore non-sig-decls in these decls
  56                 -> TcM TcGblEnv
  57
  58 -- May 2003:
  59 --      NOTE 1: careful about the side-effected EPS
  60 --              in the two tcExtendGlobalValueEnv calls
  61 --      NOTE 2: no point in tying the knot with fixM; all
  62 --              the important knot-tying comes via the PCS global variable
  63
  64 tcInterfaceSigs decls =
  65   zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) ->
  66         -- The zapEnv dramatically trims the environment, solely
  67         -- to plug the space leak that would otherwise be caused
  68         -- by a rich environment bound into lots of lazy thunks
  69         -- The thunks are the lazily-typechecked IdInfo of the
  70         -- imported things.
  71
  72   tcExtendGlobalValEnv sig_ids getGblEnv  `thenM` \ gbl_env ->
  73   returnM gbl_env
  74         -- We tie a knot so that the Ids read out of interfaces are in scope
  75         --   when we read their pragmas.
  76         -- What we rely on is that pragmas are typechecked lazily; if
  77         --   any type errors are found (ie there's an inconsistency)
  78         --   we silently discard the pragma
  79         --
  80         -- NOTE ALSO: the knot is in two parts:
  81         --      * Ids defined in this module are added to the typechecker envt
  82         --        which is knot-tied by the fixM.
  83         --      * Imported Ids are side-effected into the PCS by the
  84         --        tcExtendGlobalValueEnv, so they will be seen there provided
  85         --        we don't look them up too early.
  86         --      In both cases, we must defer lookups until after the knot is tied
  87         --
  88         -- We used to have a much bigger loop (in TcRnDriver), so that the
  89         -- interface pragmas could mention variables bound in this module
  90         -- (by mutual recn), but
  91         --     (a) the knot is tiresomely big, and
  92         --     (b) it black-holes when we have Template Haskell
  93         --
  94         -- For (b) consider: f = $(...h....)
  95         -- where h is imported, and calls f via an hi-boot file.
  96         -- This is bad!  But it is not seen as a staging error, because h
  97         -- is indeed imported.  We don't want the type-checker to black-hole
  98         -- when simplifying and compiling the splice!
  99         --
 100         -- Simple solution: discard any unfolding that mentions a variable
 101         -- bound in this module (and hence not yet processed).
 102         -- The discarding happens when forkM finds a type error.
 103
 104 tc_interface_sigs decls ~(unf_env, _)
 105   = sequenceM [do_one d | d@(IfaceSig {}) <- decls]     `thenM` \ sig_ids ->
 106     tcExtendGlobalValEnv sig_ids getGblEnv              `thenM` \ gbl_env ->
 107     returnM (gbl_env, sig_ids)
 108   where
 109     in_scope_vars = typeEnvIds (tcg_type_env unf_env)
 110         -- When we have hi-boot files, an unfolding might refer to
 111         -- something defined in this module, so we must build a
 112         -- suitable in-scope set.  This thunk will only be poked
 113         -- if -dcore-lint is on.
 114
 115     do_one IfaceSig {tcdName   = name,     tcdType = ty,
 116                      tcdIdInfo = id_infos, tcdLoc  = src_loc}
 117       = addSrcLoc src_loc                       $
 118         addErrCtxt (ifaceSigCtxt name)          $
 119         tcIfaceType ty                          `thenM` \ sigma_ty ->
 120         tcIdInfo unf_env in_scope_vars name
 121                  sigma_ty id_infos              `thenM` \ id_info ->
 122         returnM (mkVanillaGlobal name sigma_ty id_info)
 123 \end{code}
 124
 125 \begin{code}
 126 tcIdInfo unf_env in_scope_vars name ty info_ins
 127   = setGblEnv unf_env $
 128         -- Use the knot-tied environment for the IdInfo
 129         -- In particular: typechecking unfoldings and worker names
 130     foldlM tcPrag init_info info_ins
 131   where
 132     -- Set the CgInfo to something sensible but uninformative before
 133     -- we start; default assumption is that it has CAFs
 134     init_info = vanillaIdInfo
 135
 136     tcPrag info HsNoCafRefs         = returnM (info `setCafInfo`   NoCafRefs)
 137     tcPrag info (HsArity arity)     = returnM (info `setArityInfo` arity)
 138     tcPrag info (HsStrictness str)  = returnM (info `setAllStrictnessInfo` Just str)
 139     tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
 140
 141     tcPrag info (HsUnfold inline_prag expr)
 142         = tcPragExpr name in_scope_vars expr    `thenM` \ maybe_expr' ->
 143           let
 144                 -- maybe_expr' doesn't get looked at if the unfolding
 145                 -- is never inspected; so the typecheck doesn't even happen
 146                 unfold_info = case maybe_expr' of
 147                                 Nothing    -> noUnfolding
 148                                 Just expr' -> mkTopUnfolding expr'
 149           in
 150           returnM (info `setUnfoldingInfoLazily` unfold_info
 151                         `setInlinePragInfo`      inline_prag)
 152 \end{code}
 153
 154 \begin{code}
 155 tcWorkerInfo ty info wkr_name arity
 156   = forkM doc (tcVar wkr_name)  `thenM` \ maybe_wkr_id ->
 157         -- Watch out! We can't pull on unf_env too eagerly!
 158         -- Hence the forkM
 159
 160         -- We return without testing maybe_wkr_id, but as soon as info is
 161         -- looked at we will test it.  That's ok, because its outside the
 162         -- knot; and there seems no big reason to further defer the
 163         -- tcVar lookup.  (Contrast with tcPragExpr, where postponing walking
 164         -- over the unfolding until it's actually used does seem worth while.)
 165     newUniqueSupply             `thenM` \ us ->
 166     returnM (case maybe_wkr_id of
 167         Nothing     -> info
 168         Just wkr_id -> info `setUnfoldingInfoLazily`  mk_unfolding us wkr_id
 169                             `setWorkerInfo`           HasWorker wkr_id arity)
 170
 171   where
 172     doc = text "worker for" <+> ppr wkr_name
 173
 174     mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
 175
 176         -- We are relying here on strictness info always appearing
 177         -- before worker info,  fingers crossed ....
 178     strict_sig = case newStrictnessInfo info of
 179                    Just sig -> sig
 180                    Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr_name)
 181 \end{code}
 182
 183 For unfoldings we try to do the job lazily, so that we never type check
 184 an unfolding that isn't going to be looked at.
 185
 186 \begin{code}
 187 tcPragExpr :: Name -> [Id] -> UfExpr Name -> TcM (Maybe CoreExpr)
 188 tcPragExpr name in_scope_vars expr
 189   = forkM doc $
 190     tcCoreExpr expr             `thenM` \ core_expr' ->
 191
 192                 -- Check for type consistency in the unfolding
 193     ifOptM Opt_DoCoreLinting (
 194         getSrcLocM              `thenM` \ src_loc ->
 195         case lintUnfolding src_loc in_scope_vars core_expr' of
 196           Nothing       -> returnM ()
 197           Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg)
 198     )                           `thenM_`
 199
 200    returnM core_expr'
 201   where
 202     doc = text "unfolding of" <+> ppr name
 203 \end{code}
 204
 205
 206 Variables in unfoldings
 207 ~~~~~~~~~~~~~~~~~~~~~~~
 208
 209 \begin{code}
 210 tcVar :: Name -> TcM Id
 211   -- Inside here we use only the Global environment, even for locally bound variables.
 212   -- Why? Because we know all the types and want to bind them to real Ids.
 213 tcVar name = tcLookupGlobalId name
 214 \end{code}
 215
 216 UfCore expressions.
 217
 218 \begin{code}
 219 tcCoreExpr :: UfExpr Name -> TcM CoreExpr
 220
 221 tcCoreExpr (UfType ty)
 222   = tcIfaceType ty              `thenM` \ ty' ->
 223         -- It might not be of kind type
 224     returnM (Type ty')
 225
 226 tcCoreExpr (UfVar name)
 227   = tcVar name  `thenM` \ id ->
 228     returnM (Var id)
 229
 230 tcCoreExpr (UfLit lit)
 231   = returnM (Lit lit)
 232
 233 -- The dreaded lit-lits are also similar, except here the type
 234 -- is read in explicitly rather than being implicit
 235 tcCoreExpr (UfLitLit lit ty)
 236   = tcIfaceType ty              `thenM` \ ty' ->
 237     returnM (Lit (MachLitLit lit ty'))
 238
 239 tcCoreExpr (UfFCall cc ty)
 240   = tcIfaceType ty      `thenM` \ ty' ->
 241     newUnique           `thenM` \ u ->
 242     returnM (Var (mkFCallId u cc ty'))
 243
 244 tcCoreExpr (UfTuple (HsTupCon boxity arity) args)
 245   = mappM tcCoreExpr args       `thenM` \ args' ->
 246     let
 247         -- Put the missing type arguments back in
 248         con_args = map (Type . exprType) args' ++ args'
 249     in
 250     returnM (mkApps (Var con_id) con_args)
 251   where
 252     con_id = dataConWorkId (tupleCon boxity arity)
 253
 254
 255 tcCoreExpr (UfLam bndr body)
 256   = tcCoreLamBndr bndr          $ \ bndr' ->
 257     tcCoreExpr body             `thenM` \ body' ->
 258     returnM (Lam bndr' body')
 259
 260 tcCoreExpr (UfApp fun arg)
 261   = tcCoreExpr fun              `thenM` \ fun' ->
 262     tcCoreExpr arg              `thenM` \ arg' ->
 263     returnM (App fun' arg')
 264
 265 tcCoreExpr (UfCase scrut case_bndr alts)
 266   = tcCoreExpr scrut                                    `thenM` \ scrut' ->
 267     let
 268         scrut_ty = exprType scrut'
 269         case_bndr' = mkLocalId case_bndr scrut_ty
 270     in
 271     tcExtendGlobalValEnv [case_bndr']   $
 272     mappM (tcCoreAlt scrut_ty) alts     `thenM` \ alts' ->
 273     returnM (Case scrut' case_bndr' alts')
 274
 275 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 276   = tcCoreExpr rhs              `thenM` \ rhs' ->
 277     tcCoreValBndr bndr          $ \ bndr' ->
 278     tcCoreExpr body             `thenM` \ body' ->
 279     returnM (Let (NonRec bndr' rhs') body')
 280
 281 tcCoreExpr (UfLet (UfRec pairs) body)
 282   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 283     mappM tcCoreExpr rhss       `thenM` \ rhss' ->
 284     tcCoreExpr body             `thenM` \ body' ->
 285     returnM (Let (Rec (bndrs' `zip` rhss')) body')
 286   where
 287     (bndrs, rhss) = unzip pairs
 288
 289 tcCoreExpr (UfNote note expr)
 290   = tcCoreExpr expr             `thenM` \ expr' ->
 291     case note of
 292         UfCoerce to_ty -> tcIfaceType to_ty     `thenM` \ to_ty' ->
 293                           returnM (Note (Coerce to_ty'
 294                                                  (exprType expr')) expr')
 295         UfInlineCall   -> returnM (Note InlineCall expr')
 296         UfInlineMe     -> returnM (Note InlineMe   expr')
 297         UfSCC cc       -> returnM (Note (SCC cc)   expr')
 298 \end{code}
 299
 300 \begin{code}
 301 tcCoreLamBndr (UfValBinder name ty) thing_inside
 302   = tcIfaceType ty              `thenM` \ ty' ->
 303     let
 304         id = mkLocalId name ty'
 305     in
 306     tcExtendGlobalValEnv [id] $
 307     thing_inside id
 308
 309 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 310   = let
 311         tyvar = mkTyVar name kind
 312     in
 313     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 314
 315 tcCoreLamBndrs []     thing_inside = thing_inside []
 316 tcCoreLamBndrs (b:bs) thing_inside
 317   = tcCoreLamBndr b     $ \ b' ->
 318     tcCoreLamBndrs bs   $ \ bs' ->
 319     thing_inside (b':bs')
 320
 321 tcCoreValBndr (UfValBinder name ty) thing_inside
 322   = tcIfaceType ty                      `thenM` \ ty' ->
 323     let
 324         id = mkLocalId name ty'
 325     in
 326     tcExtendGlobalValEnv [id] $
 327     thing_inside id
 328
 329 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 330   = mappM tcIfaceType tys               `thenM` \ tys' ->
 331     let
 332         ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
 333     in
 334     tcExtendGlobalValEnv ids $
 335     thing_inside ids
 336   where
 337     names = [name | UfValBinder name _  <- bndrs]
 338     tys   = [ty   | UfValBinder _    ty <- bndrs]
 339 \end{code}
 340
 341 \begin{code}
 342 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 343   = ASSERT( null names )
 344     tcCoreExpr rhs              `thenM` \ rhs' ->
 345     returnM (DEFAULT, [], rhs')
 346
 347 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 348   = ASSERT( null names )
 349     tcCoreExpr rhs              `thenM` \ rhs' ->
 350     returnM (LitAlt lit, [], rhs')
 351
 352 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 353   = ASSERT( null names )
 354     tcCoreExpr rhs              `thenM` \ rhs' ->
 355     tcIfaceType ty              `thenM` \ ty' ->
 356     returnM (LitAlt (MachLitLit str ty'), [], rhs')
 357
 358 -- A case alternative is made quite a bit more complicated
 359 -- by the fact that we omit type annotations because we can
 360 -- work them out.  True enough, but its not that easy!
 361 tcCoreAlt scrut_ty alt@(con, names, rhs)
 362   = tcConAlt con        `thenM` \ con ->
 363     let
 364         ex_tyvars         = dataConExistentialTyVars con
 365         (tycon, inst_tys) = splitTyConApp scrut_ty      -- NB: not tcSplitTyConApp
 366                                                         -- We are looking at Core here
 367         main_tyvars       = tyConTyVars tycon
 368         ex_tyvars'        = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 369         ex_tys'           = mkTyVarTys ex_tyvars'
 370         arg_tys           = dataConArgTys con (inst_tys ++ ex_tys')
 371         id_names          = dropList ex_tyvars names
 372         arg_ids
 373 #ifdef DEBUG
 374                 | not (equalLength id_names arg_tys)
 375                 = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
 376                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 377                                          ppr arg_tys)
 378                 | otherwise
 379 #endif
 380                 = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
 381     in
 382     ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
 383     tcExtendTyVarEnv ex_tyvars'                 $
 384     tcExtendGlobalValEnv arg_ids                $
 385     tcCoreExpr rhs                                      `thenM` \ rhs' ->
 386     returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 387
 388
 389 tcConAlt :: UfConAlt Name -> TcM DataCon
 390 tcConAlt (UfTupleAlt (HsTupCon boxity arity))
 391   = returnM (tupleCon boxity arity)
 392
 393 tcConAlt (UfDataAlt con_name)   -- When reading interface files
 394                                 -- the con_name will be the real name of
 395                                 -- the data con
 396   = tcLookupDataCon con_name
 397 \end{code}
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection{Core decls}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405
 406 \begin{code}
 407 tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind]
 408 -- We don't assume the bindings are in dependency order
 409 -- So first build the environment, then check the RHSs
 410 tcCoreBinds ls = mappM tcCoreBinder ls          `thenM` \ bndrs ->
 411                  tcExtendGlobalValEnv bndrs     $
 412                  mappM (tcCoreBind bndrs) ls
 413
 414 tcCoreBinder (CoreDecl nm ty _ _)
 415  = kcHsSigType ty       `thenM_`
 416    tcIfaceType ty       `thenM` \ ty' ->
 417    returnM (mkLocalId nm ty')
 418
 419 tcCoreBind bndrs (CoreDecl nm _ rhs loc)
 420  = tcVar nm             `thenM` \ id ->
 421    tcCoreExpr rhs       `thenM` \ rhs' ->
 422    let
 423         mb_err = lintUnfolding loc bndrs rhs'
 424    in
 425    (case mb_err of
 426         Just err -> addErr err
 427         Nothing  -> returnM ()) `thenM_`
 428
 429    returnM (id, rhs')
 430 \end{code}
 431
 432
 433 \begin{code}
 434 ifaceSigCtxt sig_name
 435   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 436 \end{code}
 437