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 tcCoreExpr (UfFCall cc ty)
 234   = tcIfaceType ty      `thenM` \ ty' ->
 235     newUnique           `thenM` \ u ->
 236     returnM (Var (mkFCallId u cc ty'))
 237
 238 tcCoreExpr (UfTuple (HsTupCon boxity arity) args)
 239   = mappM tcCoreExpr args       `thenM` \ args' ->
 240     let
 241         -- Put the missing type arguments back in
 242         con_args = map (Type . exprType) args' ++ args'
 243     in
 244     returnM (mkApps (Var con_id) con_args)
 245   where
 246     con_id = dataConWorkId (tupleCon boxity arity)
 247
 248
 249 tcCoreExpr (UfLam bndr body)
 250   = tcCoreLamBndr bndr          $ \ bndr' ->
 251     tcCoreExpr body             `thenM` \ body' ->
 252     returnM (Lam bndr' body')
 253
 254 tcCoreExpr (UfApp fun arg)
 255   = tcCoreExpr fun              `thenM` \ fun' ->
 256     tcCoreExpr arg              `thenM` \ arg' ->
 257     returnM (App fun' arg')
 258
 259 tcCoreExpr (UfCase scrut case_bndr alts)
 260   = tcCoreExpr scrut                                    `thenM` \ scrut' ->
 261     let
 262         scrut_ty = exprType scrut'
 263         case_bndr' = mkLocalId case_bndr scrut_ty
 264     in
 265     tcExtendGlobalValEnv [case_bndr']   $
 266     mappM (tcCoreAlt scrut_ty) alts     `thenM` \ alts' ->
 267     returnM (Case scrut' case_bndr' alts')
 268
 269 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
 270   = tcCoreExpr rhs              `thenM` \ rhs' ->
 271     tcCoreValBndr bndr          $ \ bndr' ->
 272     tcCoreExpr body             `thenM` \ body' ->
 273     returnM (Let (NonRec bndr' rhs') body')
 274
 275 tcCoreExpr (UfLet (UfRec pairs) body)
 276   = tcCoreValBndrs bndrs        $ \ bndrs' ->
 277     mappM tcCoreExpr rhss       `thenM` \ rhss' ->
 278     tcCoreExpr body             `thenM` \ body' ->
 279     returnM (Let (Rec (bndrs' `zip` rhss')) body')
 280   where
 281     (bndrs, rhss) = unzip pairs
 282
 283 tcCoreExpr (UfNote note expr)
 284   = tcCoreExpr expr             `thenM` \ expr' ->
 285     case note of
 286         UfCoerce to_ty -> tcIfaceType to_ty     `thenM` \ to_ty' ->
 287                           returnM (Note (Coerce to_ty'
 288                                                  (exprType expr')) expr')
 289         UfInlineCall   -> returnM (Note InlineCall expr')
 290         UfInlineMe     -> returnM (Note InlineMe   expr')
 291         UfSCC cc       -> returnM (Note (SCC cc)   expr')
 292 \end{code}
 293
 294 \begin{code}
 295 tcCoreLamBndr (UfValBinder name ty) thing_inside
 296   = tcIfaceType ty              `thenM` \ ty' ->
 297     let
 298         id = mkLocalId name ty'
 299     in
 300     tcExtendGlobalValEnv [id] $
 301     thing_inside id
 302
 303 tcCoreLamBndr (UfTyBinder name kind) thing_inside
 304   = let
 305         tyvar = mkTyVar name kind
 306     in
 307     tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
 308
 309 tcCoreLamBndrs []     thing_inside = thing_inside []
 310 tcCoreLamBndrs (b:bs) thing_inside
 311   = tcCoreLamBndr b     $ \ b' ->
 312     tcCoreLamBndrs bs   $ \ bs' ->
 313     thing_inside (b':bs')
 314
 315 tcCoreValBndr (UfValBinder name ty) thing_inside
 316   = tcIfaceType ty                      `thenM` \ ty' ->
 317     let
 318         id = mkLocalId name ty'
 319     in
 320     tcExtendGlobalValEnv [id] $
 321     thing_inside id
 322
 323 tcCoreValBndrs bndrs thing_inside               -- Expect them all to be ValBinders
 324   = mappM tcIfaceType tys               `thenM` \ tys' ->
 325     let
 326         ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
 327     in
 328     tcExtendGlobalValEnv ids $
 329     thing_inside ids
 330   where
 331     names = [name | UfValBinder name _  <- bndrs]
 332     tys   = [ty   | UfValBinder _    ty <- bndrs]
 333 \end{code}
 334
 335 \begin{code}
 336 tcCoreAlt scrut_ty (UfDefault, names, rhs)
 337   = ASSERT( null names )
 338     tcCoreExpr rhs              `thenM` \ rhs' ->
 339     returnM (DEFAULT, [], rhs')
 340
 341 tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 342   = ASSERT( null names )
 343     tcCoreExpr rhs              `thenM` \ rhs' ->
 344     returnM (LitAlt lit, [], rhs')
 345
 346 -- A case alternative is made quite a bit more complicated
 347 -- by the fact that we omit type annotations because we can
 348 -- work them out.  True enough, but its not that easy!
 349 tcCoreAlt scrut_ty alt@(con, names, rhs)
 350   = tcConAlt con        `thenM` \ con ->
 351     let
 352         ex_tyvars         = dataConExistentialTyVars con
 353         (tycon, inst_tys) = splitTyConApp scrut_ty      -- NB: not tcSplitTyConApp
 354                                                         -- We are looking at Core here
 355         main_tyvars       = tyConTyVars tycon
 356         ex_tyvars'        = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
 357         ex_tys'           = mkTyVarTys ex_tyvars'
 358         arg_tys           = dataConArgTys con (inst_tys ++ ex_tys')
 359         id_names          = dropList ex_tyvars names
 360         arg_ids
 361 #ifdef DEBUG
 362                 | not (equalLength id_names arg_tys)
 363                 = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
 364                                          (ppr main_tyvars <+> ppr ex_tyvars) $$
 365                                          ppr arg_tys)
 366                 | otherwise
 367 #endif
 368                 = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
 369     in
 370     ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
 371     tcExtendTyVarEnv ex_tyvars'                 $
 372     tcExtendGlobalValEnv arg_ids                $
 373     tcCoreExpr rhs                                      `thenM` \ rhs' ->
 374     returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 375
 376
 377 tcConAlt :: UfConAlt Name -> TcM DataCon
 378 tcConAlt (UfTupleAlt (HsTupCon boxity arity))
 379   = returnM (tupleCon boxity arity)
 380
 381 tcConAlt (UfDataAlt con_name)   -- When reading interface files
 382                                 -- the con_name will be the real name of
 383                                 -- the data con
 384   = tcLookupDataCon con_name
 385 \end{code}
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{Core decls}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393
 394 \begin{code}
 395 tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind]
 396 -- We don't assume the bindings are in dependency order
 397 -- So first build the environment, then check the RHSs
 398 tcCoreBinds ls = mappM tcCoreBinder ls          `thenM` \ bndrs ->
 399                  tcExtendGlobalValEnv bndrs     $
 400                  mappM (tcCoreBind bndrs) ls
 401
 402 tcCoreBinder (CoreDecl nm ty _ _)
 403  = kcHsSigType ty       `thenM_`
 404    tcIfaceType ty       `thenM` \ ty' ->
 405    returnM (mkLocalId nm ty')
 406
 407 tcCoreBind bndrs (CoreDecl nm _ rhs loc)
 408  = tcVar nm             `thenM` \ id ->
 409    tcCoreExpr rhs       `thenM` \ rhs' ->
 410    let
 411         mb_err = lintUnfolding loc bndrs rhs'
 412    in
 413    (case mb_err of
 414         Just err -> addErr err
 415         Nothing  -> returnM ()) `thenM_`
 416
 417    returnM (id, rhs')
 418 \end{code}
 419
 420
 421 \begin{code}
 422 ifaceSigCtxt sig_name
 423   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
 424 \end{code}
 425