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 Nothing 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` \ tc_sigma_ty ->
 275         let
 276             (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty
 277         in
 278         tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val ->
 279         unifyTauTy (idType val) tau_ty  `thenTc_`
 280         returnTc (TySigInfo val tyvars theta tau_ty src_loc)
 281    )            `thenTc` \ sig_info1 ->
 282
 283    tcTySigs other_sigs  `thenTc` \ sig_infos ->
 284    returnTc (sig_info1 : sig_infos)
 285
 286 tcTySigs (other : sigs) = tcTySigs sigs
 287 tcTySigs []             = returnTc []
 288 \end{code}
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 \subsection{SPECIALIZE pragmas}
 294 %*                                                                      *
 295 %************************************************************************
 296
 297
 298 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
 299 pragmas.  It is convenient for them to appear in the @[RenamedSig]@
 300 part of a binding because then the same machinery can be used for
 301 moving them into place as is done for type signatures.
 302
 303 \begin{code}
 304 tcPragmaSigs :: [RenamedSig]                    -- The pragma signatures
 305              -> TcM s (Name -> PragmaInfo,      -- Maps name to the appropriate PragmaInfo
 306                        TcHsBinds s,
 307                        LIE s)
 308
 309 tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
 310
 311 {-
 312 tcPragmaSigs sigs
 313   = mapAndUnzip3Tc tcPragmaSig sigs     `thenTc` \ (names_w_id_infos, binds, lies) ->
 314     let
 315         name_to_info name = foldr ($) noIdInfo
 316                                   [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
 317     in
 318     returnTc (name_to_info,
 319               foldr ThenBinds EmptyBinds binds,
 320               foldr plusLIE emptyLIE lies)
 321 \end{code}
 322
 323 Here are the easy cases for tcPragmaSigs
 324
 325 \begin{code}
 326 tcPragmaSig (DeforestSig name loc)
 327   = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
 328 tcPragmaSig (InlineSig name loc)
 329   = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
 330 tcPragmaSig (MagicUnfoldingSig name string loc)
 331   = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
 332 \end{code}
 333
 334 The interesting case is for SPECIALISE pragmas.  There are two forms.
 335 Here's the first form:
 336 \begin{verbatim}
 337         f :: Ord a => [a] -> b -> b
 338         {-# SPECIALIZE f :: [Int] -> b -> b #-}
 339 \end{verbatim}
 340
 341 For this we generate:
 342 \begin{verbatim}
 343         f* = /\ b -> let d1 = ...
 344                      in f Int b d1
 345 \end{verbatim}
 346
 347 where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
 348 retain a right-hand-side that the simplifier will otherwise discard as
 349 dead code... the simplifier has a flag that tells it not to discard
 350 SpecPragmaId bindings.
 351
 352 In this case the f* retains a call-instance of the overloaded
 353 function, f, (including appropriate dictionaries) so that the
 354 specialiser will subsequently discover that there's a call of @f@ at
 355 Int, and will create a specialisation for @f@.  After that, the
 356 binding for @f*@ can be discarded.
 357
 358 The second form is this:
 359 \begin{verbatim}
 360         f :: Ord a => [a] -> b -> b
 361         {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
 362 \end{verbatim}
 363
 364 Here @g@ is specified as a function that implements the specialised
 365 version of @f@.  Suppose that g has type (a->b->b); that is, g's type
 366 is more general than that required.  For this we generate
 367 \begin{verbatim}
 368         f@Int = /\b -> g Int b
 369         f* = f@Int
 370 \end{verbatim}
 371
 372 Here @f@@Int@ is a SpecId, the specialised version of @f@.  It inherits
 373 f's export status etc.  @f*@ is a SpecPragmaId, as before, which just serves
 374 to prevent @f@@Int@ from being discarded prematurely.  After specialisation,
 375 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
 376 discard the f* binding.
 377
 378 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
 379 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
 380 a bit of overkill.
 381
 382 \begin{code}
 383 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 384   = tcAddSrcLoc src_loc                         $
 385     tcAddErrCtxt (valSpecSigCtxt name spec_ty)  $
 386
 387         -- Get and instantiate its alleged specialised type
 388     tcPolyType poly_ty                          `thenTc` \ sig_sigma ->
 389     tcInstType [] (idType sig_sigma)            `thenNF_Tc` \ sig_ty ->
 390     let
 391         (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
 392         origin = ValSpecOrigin name
 393     in
 394
 395         -- Check that the SPECIALIZE pragma had an empty context
 396     checkTc (null sig_theta)
 397             (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
 398
 399         -- Get and instantiate the type of the id mentioned
 400     tcLookupLocalValueOK "tcPragmaSig" name     `thenNF_Tc` \ main_id ->
 401     tcInstType [] (idType main_id)              `thenNF_Tc` \ main_ty ->
 402     let
 403         (main_tyvars, main_rho) = splitForAllTy main_ty
 404         (main_theta,main_tau)   = splitRhoTy main_rho
 405         main_arg_tys            = mkTyVarTys main_tyvars
 406     in
 407
 408         -- Check that the specialised type is indeed an instance of
 409         -- the type of the main function.
 410     unifyTauTy sig_tau main_tau                 `thenTc_`
 411     checkSigTyVars sig_tyvars sig_tau main_tau  `thenTc_`
 412
 413         -- Check that the type variables of the polymorphic function are
 414         -- either left polymorphic, or instantiate to ground type.
 415         -- Also check that the overloaded type variables are instantiated to
 416         -- ground type; or equivalently that all dictionaries have ground type
 417     mapTc zonkTcType main_arg_tys       `thenNF_Tc` \ main_arg_tys' ->
 418     zonkTcThetaType main_theta          `thenNF_Tc` \ main_theta' ->
 419     tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
 420               (checkTc (all isGroundOrTyVarTy main_arg_tys'))           `thenTc_`
 421     tcAddErrCtxt (specContextGroundnessCtxt main_theta')
 422               (checkTc (and [isGroundTy ty | (_,ty) <- theta']))        `thenTc_`
 423
 424         -- Build the SpecPragmaId; it is the thing that makes sure we
 425         -- don't prematurely dead-code-eliminate the binding we are really interested in.
 426     newSpecPragmaId name sig_ty         `thenNF_Tc` \ spec_pragma_id ->
 427
 428         -- Build a suitable binding; depending on whether we were given
 429         -- a value (Maybe Name) to be used as the specialisation.
 430     case using of
 431       Nothing ->                -- No implementation function specified
 432
 433                 -- Make a Method inst for the occurrence of the overloaded function
 434         newMethodWithGivenTy (OccurrenceOf name)
 435                   (TcId main_id) main_arg_tys main_rho  `thenNF_Tc` \ (lie, meth_id) ->
 436
 437         let
 438             pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
 439             pseudo_rhs  = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
 440         in
 441         returnTc (pseudo_bind, lie, \ info -> info)
 442
 443       Just spec_name ->         -- Use spec_name as the specialisation value ...
 444
 445                 -- Type check a simple occurrence of the specialised Id
 446         tcId spec_name          `thenTc` \ (spec_body, spec_lie, spec_tau) ->
 447
 448                 -- Check that it has the correct type, and doesn't constrain the
 449                 -- signature variables at all
 450         unifyTauTy sig_tau spec_tau                     `thenTc_`
 451         checkSigTyVars sig_tyvars sig_tau spec_tau      `thenTc_`
 452
 453             -- Make a local SpecId to bind to applied spec_id
 454         newSpecId main_id main_arg_tys sig_ty   `thenNF_Tc` \ local_spec_id ->
 455
 456         let
 457             spec_rhs   = mkHsTyLam sig_tyvars spec_body
 458             spec_binds = VarMonoBind local_spec_id spec_rhs
 459                            `AndMonoBinds`
 460                          VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
 461             spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
 462         in
 463         returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
 464 -}
 465 \end{code}
 466
 467
 468 Error contexts and messages
 469 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 470 \begin{code}
 471 patMonoBindsCtxt bind sty
 472   = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
 473
 474 --------------------------------------------
 475 specContextGroundnessCtxt -- err_ctxt dicts sty
 476   = panic "specContextGroundnessCtxt"
 477 {-
 478   = ppHang (
 479         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 480                ppBesides [ppStr " specialised to the type `", ppr sty spec_ty,  ppStr "'"],
 481                pp_spec_id sty,
 482                ppStr "... not all overloaded type variables were instantiated",
 483                ppStr "to ground types:"])
 484       4 (ppAboves [ppCat [ppr sty c, ppr sty t]
 485                   | (c,t) <- map getDictClassAndType dicts])
 486   where
 487     (name, spec_ty, locn, pp_spec_id)
 488       = case err_ctxt of
 489           ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
 490           ValSpecSpecIdCtxt n ty spec loc ->
 491             (n, ty, loc,
 492              \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
 493 -}
 494
 495 -----------------------------------------------
 496 specGroundnessCtxt
 497   = panic "specGroundnessCtxt"
 498
 499
 500 valSpecSigCtxt v ty sty
 501   = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
 502          4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),
 503                   ppr sty ty])
 504 \end{code}
 505