ghc/compiler/typecheck/TcBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcBinds]{TcBinds}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
  10
  11 import Ubiq
  12
  13 import HsSyn            ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
  14                           HsExpr, Match, PolyType, InPat, OutPat,
  15                           GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
  16                           collectBinders )
  17 import RnHsSyn          ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
  18                           RenamedMonoBinds(..) )
  19 import TcHsSyn          ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
  20                           TcIdOcc(..), TcIdBndr(..) )
  21
  22 import TcMonad
  23 import GenSpecEtc       ( checkSigTyVars, genBinds, TcSigInfo(..) )
  24 import Inst             ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
  25 import TcEnv            ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
  26 import TcLoop           ( tcGRHSsAndBinds )
  27 import TcMatches        ( tcMatchesFun )
  28 import TcMonoType       ( tcPolyType )
  29 import TcPat            ( tcPat )
  30 import TcSimplify       ( bindInstsOfLocalFuns )
  31 import TcType           ( newTcTyVar, tcInstType )
  32 import Unify            ( unifyTauTy )
  33
  34 import Kind             ( mkBoxedTypeKind, mkTypeKind )
  35 import Id               ( GenId, idType, mkUserId )
  36 import IdInfo           ( noIdInfo )
  37 import Name             ( Name )        -- instances
  38 import Maybes           ( assocMaybe, catMaybes, Maybe(..) )
  39 import Outputable       ( pprNonOp )
  40 import PragmaInfo       ( PragmaInfo(..) )
  41 import Pretty
  42 import Type             ( mkTyVarTy, isTyVarTy, mkSigmaTy, splitSigmaTy,
  43                           splitRhoTy, mkForAllTy, splitForAllTy )
  44 import Util             ( panic )
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection{Type-checking bindings}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 @tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
  54 it needs to know something about the {\em usage} of the things bound,
  55 so that it can create specialisations of them.  So @tcBindsAndThen@
  56 takes a function which, given an extended environment, E, typechecks
  57 the scope of the bindings returning a typechecked thing and (most
  58 important) an LIE.  It is this LIE which is then used as the basis for
  59 specialising the things bound.
  60
  61 @tcBindsAndThen@ also takes a "combiner" which glues together the
  62 bindings and the "thing" to make a new "thing".
  63
  64 The real work is done by @tcBindAndThen@.
  65
  66 Recursive and non-recursive binds are handled in essentially the same
  67 way: because of uniques there are no scoping issues left.  The only
  68 difference is that non-recursive bindings can bind primitive values.
  69
  70 Even for non-recursive binding groups we add typings for each binder
  71 to the LVE for the following reason.  When each individual binding is
  72 checked the type of its LHS is unified with that of its RHS; and
  73 type-checking the LHS of course requires that the binder is in scope.
  74
  75 At the top-level the LIE is sure to contain nothing but constant
  76 dictionaries, which we resolve at the module level.
  77
  78 \begin{code}
  79 tcBindsAndThen
  80         :: (TcHsBinds s -> thing -> thing)              -- Combinator
  81         -> RenamedHsBinds
  82         -> TcM s (thing, LIE s, thing_ty)
  83         -> TcM s (thing, LIE s, thing_ty)
  84
  85 tcBindsAndThen combiner EmptyBinds do_next
  86   = do_next     `thenTc` \ (thing, lie, thing_ty) ->
  87     returnTc (combiner EmptyBinds thing, lie, thing_ty)
  88
  89 tcBindsAndThen combiner (SingleBind bind) do_next
  90   = tcBindAndThen combiner bind [] do_next
  91
  92 tcBindsAndThen combiner (BindWith bind sigs) do_next
  93   = tcBindAndThen combiner bind sigs do_next
  94
  95 tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
  96   = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
  97 \end{code}
  98
  99 An aside.  The original version of @tcBindsAndThen@ which lacks a
 100 combiner function, appears below.  Though it is perfectly well
 101 behaved, it cannot be typed by Haskell, because the recursive call is
 102 at a different type to the definition itself.  There aren't too many
 103 examples of this, which is why I thought it worth preserving! [SLPJ]
 104
 105 \begin{pseudocode}
 106 tcBindsAndThen
 107         :: RenamedHsBinds
 108         -> TcM s (thing, LIE s, thing_ty))
 109         -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
 110
 111 tcBindsAndThen EmptyBinds do_next
 112   = do_next             `thenTc` \ (thing, lie, thing_ty) ->
 113     returnTc ((EmptyBinds, thing), lie, thing_ty)
 114
 115 tcBindsAndThen (SingleBind bind) do_next
 116   = tcBindAndThen bind [] do_next
 117
 118 tcBindsAndThen (BindWith bind sigs) do_next
 119   = tcBindAndThen bind sigs do_next
 120
 121 tcBindsAndThen (ThenBinds binds1 binds2) do_next
 122   = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
 123         `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
 124
 125     returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
 126 \end{pseudocode}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection{Bind}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 tcBindAndThen
 136         :: (TcHsBinds s -> thing -> thing)                -- Combinator
 137         -> RenamedBind                                    -- The Bind to typecheck
 138         -> [RenamedSig]                                   -- ...and its signatures
 139         -> TcM s (thing, LIE s, thing_ty)                 -- Thing to type check in
 140                                                           -- augmented envt
 141         -> TcM s (thing, LIE s, thing_ty)                 -- Results, incl the
 142
 143 tcBindAndThen combiner bind sigs do_next
 144   = fixTc (\ ~(prag_info_fn, _) ->
 145         -- This is the usual prag_info fix; the PragmaInfo field of an Id
 146         -- is not inspected till ages later in the compiler, so there
 147         -- should be no black-hole problems here.
 148
 149     tcBindAndSigs binder_names bind
 150                   sigs prag_info_fn     `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
 151
 152         -- Extend the environment to bind the new polymorphic Ids
 153     tcExtendLocalValEnv binder_names poly_ids $
 154
 155         -- Build bindings and IdInfos corresponding to user pragmas
 156     tcPragmaSigs sigs                   `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
 157
 158         -- Now do whatever happens next, in the augmented envt
 159     do_next                             `thenTc` \ (thing, thing_lie, thing_ty) ->
 160
 161         -- Create specialisations of functions bound here
 162     bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
 163                           poly_ids      `thenTc` \ (lie2, inst_mbinds) ->
 164
 165         -- All done
 166     let
 167         final_lie   = lie2 `plusLIE` poly_lie
 168         final_binds = poly_binds `ThenBinds`
 169                       SingleBind (NonRecBind inst_mbinds) `ThenBinds`
 170                       prag_binds
 171     in
 172     returnTc (prag_info_fn, (combiner final_binds thing, final_lie, thing_ty))
 173     )                                   `thenTc` \ (_, result) ->
 174     returnTc result
 175   where
 176     binder_names = collectBinders bind
 177
 178
 179 tcBindAndSigs binder_names bind sigs prag_info_fn
 180   = recoverTc (
 181         -- If typechecking the binds fails, then return with each
 182         -- binder given type (forall a.a), to minimise subsequent
 183         -- error messages
 184         newTcTyVar Nothing mkBoxedTypeKind              `thenNF_Tc` \ alpha_tv ->
 185         let
 186           forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
 187           poly_ids   = [ mkUserId name forall_a_a (prag_info_fn name)
 188                        | name <- binder_names]
 189         in
 190         returnTc (EmptyBinds, emptyLIE, poly_ids)
 191     ) $
 192
 193         -- Create a new identifier for each binder, with each being given
 194         -- a type-variable type.
 195     newMonoIds binder_names kind (\ mono_ids ->
 196             tcTySigs sigs               `thenTc` \ sig_info ->
 197             tc_bind bind                `thenTc` \ (bind', lie) ->
 198             returnTc (mono_ids, bind', lie, sig_info)
 199     )
 200             `thenTc` \ (mono_ids, bind', lie, sig_info) ->
 201
 202             -- Notice that genBinds gets the old (non-extended) environment
 203     genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
 204   where
 205     kind = case bind of
 206                 NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types
 207                 RecBind _    -> mkTypeKind      -- Non-recursive, so we permit unboxed types
 208 \end{code}
 209
 210 \begin{code}
 211 tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
 212
 213 tc_bind (NonRecBind mono_binds)
 214   = tcMonoBinds mono_binds      `thenTc` \ (mono_binds2, lie) ->
 215     returnTc  (NonRecBind mono_binds2, lie)
 216
 217 tc_bind (RecBind mono_binds)
 218   = tcMonoBinds mono_binds      `thenTc` \ (mono_binds2, lie) ->
 219     returnTc  (RecBind mono_binds2, lie)
 220 \end{code}
 221
 222 \begin{code}
 223 tcMonoBinds :: RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s)
 224
 225 tcMonoBinds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
 226
 227 tcMonoBinds (AndMonoBinds mb1 mb2)
 228   = tcMonoBinds mb1             `thenTc` \ (mb1a, lie1) ->
 229     tcMonoBinds mb2             `thenTc` \ (mb2a, lie2) ->
 230     returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
 231
 232 tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn)
 233   = tcAddSrcLoc locn             $
 234
 235         -- LEFT HAND SIDE
 236     tcPat pat                           `thenTc` \ (pat2, lie_pat, pat_ty) ->
 237
 238         -- BINDINGS AND GRHSS
 239     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
 240
 241         -- Unify the two sides
 242     tcAddErrCtxt (patMonoBindsCtxt bind) $
 243         unifyTauTy pat_ty grhss_ty                      `thenTc_`
 244
 245         -- RETURN
 246     returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
 247               plusLIE lie_pat lie)
 248
 249 tcMonoBinds (FunMonoBind name matches locn)
 250   = tcAddSrcLoc locn                            $
 251     tcLookupLocalValueOK "tcMonoBinds" name     `thenNF_Tc` \ id ->
 252     tcMatchesFun name (idType id) matches       `thenTc` \ (matches', lie) ->
 253     returnTc (FunMonoBind (TcId id) matches' locn, lie)
 254 \end{code}
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsection{Signatures}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 @tcSigs@ checks the signatures for validity, and returns a list of
 263 {\em freshly-instantiated} signatures.  That is, the types are already
 264 split up, and have fresh type variables installed.  All non-type-signature
 265 "RenamedSigs" are ignored.
 266
 267 \begin{code}
 268 tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
 269
 270 tcTySigs (Sig v ty _ src_loc : other_sigs)
 271  = tcAddSrcLoc src_loc (
 272         tcPolyType ty                   `thenTc` \ sigma_ty ->
 273         tcInstType [] sigma_ty          `thenNF_Tc` \ tc_sigma_ty ->
 274         let
 275             (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty
 276         in
 277         tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val ->
 278         unifyTauTy (idType val) tau_ty  `thenTc_`
 279         returnTc (TySigInfo val tyvars theta tau_ty src_loc)
 280    )            `thenTc` \ sig_info1 ->
 281
 282    tcTySigs other_sigs  `thenTc` \ sig_infos ->
 283    returnTc (sig_info1 : sig_infos)
 284
 285 tcTySigs (other : sigs) = tcTySigs sigs
 286 tcTySigs []             = returnTc []
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{SPECIALIZE pragmas}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296
 297 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
 298 pragmas.  It is convenient for them to appear in the @[RenamedSig]@
 299 part of a binding because then the same machinery can be used for
 300 moving them into place as is done for type signatures.
 301
 302 \begin{code}
 303 tcPragmaSigs :: [RenamedSig]                    -- The pragma signatures
 304              -> TcM s (Name -> PragmaInfo,      -- Maps name to the appropriate PragmaInfo
 305                        TcHsBinds s,
 306                        LIE s)
 307
 308 tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
 309
 310 {-
 311 tcPragmaSigs sigs
 312   = mapAndUnzip3Tc tcPragmaSig sigs     `thenTc` \ (names_w_id_infos, binds, lies) ->
 313     let
 314         name_to_info name = foldr ($) noIdInfo
 315                                   [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
 316     in
 317     returnTc (name_to_info,
 318               foldr ThenBinds EmptyBinds binds,
 319               foldr plusLIE emptyLIE lies)
 320 \end{code}
 321
 322 Here are the easy cases for tcPragmaSigs
 323
 324 \begin{code}
 325 tcPragmaSig (DeforestSig name loc)
 326   = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
 327 tcPragmaSig (InlineSig name loc)
 328   = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
 329 tcPragmaSig (MagicUnfoldingSig name string loc)
 330   = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
 331 \end{code}
 332
 333 The interesting case is for SPECIALISE pragmas.  There are two forms.
 334 Here's the first form:
 335 \begin{verbatim}
 336         f :: Ord a => [a] -> b -> b
 337         {-# SPECIALIZE f :: [Int] -> b -> b #-}
 338 \end{verbatim}
 339
 340 For this we generate:
 341 \begin{verbatim}
 342         f* = /\ b -> let d1 = ...
 343                      in f Int b d1
 344 \end{verbatim}
 345
 346 where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
 347 retain a right-hand-side that the simplifier will otherwise discard as
 348 dead code... the simplifier has a flag that tells it not to discard
 349 SpecPragmaId bindings.
 350
 351 In this case the f* retains a call-instance of the overloaded
 352 function, f, (including appropriate dictionaries) so that the
 353 specialiser will subsequently discover that there's a call of @f@ at
 354 Int, and will create a specialisation for @f@.  After that, the
 355 binding for @f*@ can be discarded.
 356
 357 The second form is this:
 358 \begin{verbatim}
 359         f :: Ord a => [a] -> b -> b
 360         {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
 361 \end{verbatim}
 362
 363 Here @g@ is specified as a function that implements the specialised
 364 version of @f@.  Suppose that g has type (a->b->b); that is, g's type
 365 is more general than that required.  For this we generate
 366 \begin{verbatim}
 367         f@Int = /\b -> g Int b
 368         f* = f@Int
 369 \end{verbatim}
 370
 371 Here @f@@Int@ is a SpecId, the specialised version of @f@.  It inherits
 372 f's export status etc.  @f*@ is a SpecPragmaId, as before, which just serves
 373 to prevent @f@@Int@ from being discarded prematurely.  After specialisation,
 374 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
 375 discard the f* binding.
 376
 377 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
 378 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
 379 a bit of overkill.
 380
 381 \begin{code}
 382 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 383   = tcAddSrcLoc src_loc                         $
 384     tcAddErrCtxt (valSpecSigCtxt name spec_ty)  $
 385
 386         -- Get and instantiate its alleged specialised type
 387     tcPolyType poly_ty                          `thenTc` \ sig_sigma ->
 388     tcInstType [] (idType sig_sigma)            `thenNF_Tc` \ sig_ty ->
 389     let
 390         (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
 391         origin = ValSpecOrigin name
 392     in
 393
 394         -- Check that the SPECIALIZE pragma had an empty context
 395     checkTc (null sig_theta)
 396             (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
 397
 398         -- Get and instantiate the type of the id mentioned
 399     tcLookupLocalValueOK "tcPragmaSig" name     `thenNF_Tc` \ main_id ->
 400     tcInstType [] (idType main_id)              `thenNF_Tc` \ main_ty ->
 401     let
 402         (main_tyvars, main_rho) = splitForAllTy main_ty
 403         (main_theta,main_tau)   = splitRhoTy main_rho
 404         main_arg_tys            = map mkTyVarTy main_tyvars
 405     in
 406
 407         -- Check that the specialised type is indeed an instance of
 408         -- the type of the main function.
 409     unifyTauTy sig_tau main_tau                 `thenTc_`
 410     checkSigTyVars sig_tyvars sig_tau main_tau  `thenTc_`
 411
 412         -- Check that the type variables of the polymorphic function are
 413         -- either left polymorphic, or instantiate to ground type.
 414         -- Also check that the overloaded type variables are instantiated to
 415         -- ground type; or equivalently that all dictionaries have ground type
 416     mapTc zonkTcType main_arg_tys       `thenNF_Tc` \ main_arg_tys' ->
 417     zonkTcThetaType main_theta          `thenNF_Tc` \ main_theta' ->
 418     tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
 419               (checkTc (all isGroundOrTyVarTy main_arg_tys'))           `thenTc_`
 420     tcAddErrCtxt (specContextGroundnessCtxt main_theta')
 421               (checkTc (and [isGroundTy ty | (_,ty) <- theta']))        `thenTc_`
 422
 423         -- Build the SpecPragmaId; it is the thing that makes sure we
 424         -- don't prematurely dead-code-eliminate the binding we are really interested in.
 425     newSpecPragmaId name sig_ty         `thenNF_Tc` \ spec_pragma_id ->
 426
 427         -- Build a suitable binding; depending on whether we were given
 428         -- a value (Maybe Name) to be used as the specialisation.
 429     case using of
 430       Nothing ->                -- No implementation function specified
 431
 432                 -- Make a Method inst for the occurrence of the overloaded function
 433         newMethodWithGivenTy (OccurrenceOf name)
 434                   (TcId main_id) main_arg_tys main_rho  `thenNF_Tc` \ (lie, meth_id) ->
 435
 436         let
 437             pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
 438             pseudo_rhs  = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
 439         in
 440         returnTc (pseudo_bind, lie, \ info -> info)
 441
 442       Just spec_name ->         -- Use spec_name as the specialisation value ...
 443
 444                 -- Type check a simple occurrence of the specialised Id
 445         tcId spec_name          `thenTc` \ (spec_body, spec_lie, spec_tau) ->
 446
 447                 -- Check that it has the correct type, and doesn't constrain the
 448                 -- signature variables at all
 449         unifyTauTy sig_tau spec_tau                     `thenTc_`
 450         checkSigTyVars sig_tyvars sig_tau spec_tau      `thenTc_`
 451
 452             -- Make a local SpecId to bind to applied spec_id
 453         newSpecId main_id main_arg_tys sig_ty   `thenNF_Tc` \ local_spec_id ->
 454
 455         let
 456             spec_rhs   = mkHsTyLam sig_tyvars spec_body
 457             spec_binds = VarMonoBind local_spec_id spec_rhs
 458                            `AndMonoBinds`
 459                          VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
 460             spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
 461         in
 462         returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
 463 -}
 464 \end{code}
 465
 466
 467 Error contexts and messages
 468 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 469 \begin{code}
 470 patMonoBindsCtxt bind sty
 471   = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
 472
 473 --------------------------------------------
 474 specContextGroundnessCtxt -- err_ctxt dicts sty
 475   = panic "specContextGroundnessCtxt"
 476 {-
 477   = ppHang (
 478         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 479                ppBesides [ppStr " specialised to the type `", ppr sty spec_ty,  ppStr "'"],
 480                pp_spec_id sty,
 481                ppStr "... not all overloaded type variables were instantiated",
 482                ppStr "to ground types:"])
 483       4 (ppAboves [ppCat [ppr sty c, ppr sty t]
 484                   | (c,t) <- map getDictClassAndType dicts])
 485   where
 486     (name, spec_ty, locn, pp_spec_id)
 487       = case err_ctxt of
 488           ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
 489           ValSpecSpecIdCtxt n ty spec loc ->
 490             (n, ty, loc,
 491              \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
 492 -}
 493
 494 -----------------------------------------------
 495 specGroundnessCtxt
 496   = panic "specGroundnessCtxt"
 497
 498
 499 valSpecSigCtxt v ty sty
 500   = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
 501          4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),
 502                   ppr sty ty])
 503 \end{code}
 504