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