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