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 IMP_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          hiding ( rnMtoTcM )
  24 import GenSpecEtc       ( checkSigTyVars, genBinds, TcSigInfo(..) )
  25 import Inst             ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
  26 import TcEnv            ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
  27 IMPORT_DELOOPER(TcLoop)         ( tcGRHSsAndBinds )
  28 import TcMatches        ( tcMatchesFun )
  29 import TcMonoType       ( tcPolyType )
  30 import TcPat            ( tcPat )
  31 import TcSimplify       ( bindInstsOfLocalFuns )
  32 import TcType           ( newTcTyVar, tcInstSigType )
  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 Name             ( pprNonSym )
  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             ( isIn, zipEqual, 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 _ -> mkTypeKind      -- Recursive, so no unboxed types
 213                 RecBind _    -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types
 214 \end{code}
 215
 216
 217 ===========
 218 \begin{code}
 219 {-
 220
 221 data SigInfo
 222   = SigInfo     RnName
 223                 (TcIdBndr s)            -- Polymorpic version
 224                 (TcIdBndr s)            -- Monomorphic verstion
 225                 [TcType s] [TcIdOcc s]  -- Instance information for the monomorphic version
 226
 227
 228
 229         -- Deal with type signatures
 230     tcTySigs sigs               `thenTc` \ sig_infos ->
 231     let
 232         sig_binders   = [binder      | SigInfo binder _ _ _ _  <- sig_infos]
 233         poly_sigs     = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos]
 234         mono_sigs     = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos]
 235         nosig_binders = binders `minusList` sig_binders
 236     in
 237
 238
 239         -- Typecheck the binding group
 240     tcExtendLocalEnv poly_sigs          (
 241     newMonoIds nosig_binders kind       (\ nosig_local_ids ->
 242             tcMonoBinds mono_sigs mono_binds    `thenTc` \ binds_w_lies ->
 243             returnTc (nosig_local_ids, binds_w_lies)
 244     ))                                  `thenTc` \ (nosig_local_ids, binds_w_lies) ->
 245
 246
 247         -- Decide what to generalise over
 248     getImplicitStuffToGen sig_ids binds_w_lies
 249                         `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) ->
 250
 251
 252         *** CHECK FOR UNBOXED TYVARS HERE! ***
 253
 254
 255
 256         -- Make poly_ids for all the binders that don't have type signatures
 257     let
 258         tys_to_gen   = mkTyVarTys tyvars_to_gen
 259         dicts_to_gen = map instToId (bagToList lie_to_gen)
 260         dict_tys     = map tcIdType dicts_to_gen
 261
 262         mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo
 263                        where
 264                           ty = mkForAllTys tyvars_to_gen $
 265                                mkFunTys dict_tys $
 266                                tcIdType local_id
 267
 268         more_sig_infos = [ SigInfo binder (mk_poly binder local_id)
 269                                    local_id tys_to_gen dicts_to_gen lie_to_gen
 270                          | (binder, local_id) <- zipEqual "???" nosig_binders nosig_local_ids
 271                          ]
 272
 273         all_sig_infos = sig_infos ++ more_sig_infos     -- Contains a "signature" for each binder
 274     in
 275
 276
 277         -- Now generalise the bindings
 278     let
 279         -- local_binds is a bunch of bindings of the form
 280         --      f_mono = f_poly tyvars dicts
 281         -- one for each binder, f, that lacks a type signature.
 282         -- This bunch of bindings is put at the top of the RHS of every
 283         -- binding in the group, so as to bind all the f_monos.
 284
 285         local_binds = [ (local_id, mkHsDictApp (mkHsTyApp (HsVar local_id) tys_to_gen) dicts_to_gen)
 286                       | local_id <- nosig_local_ids
 287                       ]
 288
 289         find_sig lid = head [ (pid, tvs, ds, lie)
 290                           | SigInfo _ pid lid' tvs ds lie,
 291                             lid==lid'
 292                           ]
 293
 294       gen_bind (bind, lie)
 295         = tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie
 296                                     `thenTc` \ (lie_free, dict_binds) ->
 297           returnTc (AbsBind tyvars_to_gen_here
 298                             dicts
 299                             (zipEqual "gen_bind" local_ids poly_ids)
 300                             (dict_binds ++ local_binds)
 301                             bind,
 302                     lie_free)
 303         where
 304           local_ids  = bindersOf bind
 305           local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos,
 306                               local_id `elem` local_ids
 307                        ]
 308
 309           (tyvars_to_gen_here, dicts, avail)
 310                 = case (local_ids, sigs) of
 311
 312                     ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie])
 313                           -> (tyvars_to_gen, dicts, lie)
 314
 315                     other -> (tyvars_to_gen, dicts, avail)
 316 \end{code}
 317
 318 @getImplicitStuffToGen@ decides what type variables
 319 and LIE to generalise over.
 320
 321 For a "restricted group" -- see the monomorphism restriction
 322 for a definition -- we bind no dictionaries, and
 323 remove from tyvars_to_gen any constrained type variables
 324
 325 *Don't* simplify dicts at this point, because we aren't going
 326 to generalise over these dicts.  By the time we do simplify them
 327 we may well know more.  For example (this actually came up)
 328         f :: Array Int Int
 329         f x = array ... xs where xs = [1,2,3,4,5]
 330 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
 331 stuff.  If we simplify only at the f-binding (not the xs-binding)
 332 we'll know that the literals are all Ints, and we can just produce
 333 Int literals!
 334
 335 Find all the type variables involved in overloading, the "constrained_tyvars"
 336 These are the ones we *aren't* going to generalise.
 337 We must be careful about doing this:
 338  (a) If we fail to generalise a tyvar which is not actually
 339         constrained, then it will never, ever get bound, and lands
 340         up printed out in interface files!  Notorious example:
 341                 instance Eq a => Eq (Foo a b) where ..
 342         Here, b is not constrained, even though it looks as if it is.
 343         Another, more common, example is when there's a Method inst in
 344         the LIE, whose type might very well involve non-overloaded
 345         type variables.
 346  (b) On the other hand, we mustn't generalise tyvars which are constrained,
 347         because we are going to pass on out the unmodified LIE, with those
 348         tyvars in it.  They won't be in scope if we've generalised them.
 349
 350 So we are careful, and do a complete simplification just to find the
 351 constrained tyvars. We don't use any of the results, except to
 352 find which tyvars are constrained.
 353
 354 \begin{code}
 355 getImplicitStuffToGen is_restricted sig_ids binds_w_lies
 356   | isUnRestrictedGroup tysig_vars bind
 357   = tcSimplify tyvars_to_gen lie        `thenTc` \ (_, _, dicts_to_gen) ->
 358     returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen)
 359
 360   | otherwise
 361   = tcSimplify tyvars_to_gen lie            `thenTc` \ (_, _, constrained_dicts) ->
 362      let
 363           -- ASSERT: dicts_sig is already zonked!
 364           constrained_tyvars    = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts
 365           reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
 366      in
 367      returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE)
 368
 369   where
 370     sig_vars   = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
 371
 372     (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2,
 373                                                                lie1 `plusLIE` lie2))
 374                                     get
 375                                     (emptyTyVarSet, emptyLIE)
 376                                     binds_w_lies
 377     get (bind, lie)
 378       = case bindersOf bind of
 379           [local_id] | local_id `in` sig_ids ->         -- A simple binding with
 380                                                         -- a type signature
 381                         (emptyTyVarSet, emptyLIE)
 382
 383           local_ids ->                                  -- Complex binding or no type sig
 384                         (foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids,
 385                          lie)
 386 -}
 387 \end{code}
 388
 389
 390
 391 \begin{code}
 392 tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
 393
 394 tc_bind (NonRecBind mono_binds)
 395   = tcMonoBinds mono_binds      `thenTc` \ (mono_binds2, lie) ->
 396     returnTc  (NonRecBind mono_binds2, lie)
 397
 398 tc_bind (RecBind mono_binds)
 399   = tcMonoBinds mono_binds      `thenTc` \ (mono_binds2, lie) ->
 400     returnTc  (RecBind mono_binds2, lie)
 401 \end{code}
 402
 403 \begin{code}
 404 tcMonoBinds :: RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s)
 405
 406 tcMonoBinds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
 407
 408 tcMonoBinds (AndMonoBinds mb1 mb2)
 409   = tcMonoBinds mb1             `thenTc` \ (mb1a, lie1) ->
 410     tcMonoBinds mb2             `thenTc` \ (mb2a, lie2) ->
 411     returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
 412
 413 tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn)
 414   = tcAddSrcLoc locn             $
 415
 416         -- LEFT HAND SIDE
 417     tcPat pat                           `thenTc` \ (pat2, lie_pat, pat_ty) ->
 418
 419         -- BINDINGS AND GRHSS
 420     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
 421
 422         -- Unify the two sides
 423     tcAddErrCtxt (patMonoBindsCtxt bind) $
 424         unifyTauTy pat_ty grhss_ty                      `thenTc_`
 425
 426         -- RETURN
 427     returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
 428               plusLIE lie_pat lie)
 429
 430 tcMonoBinds (FunMonoBind name inf matches locn)
 431   = tcAddSrcLoc locn                            $
 432     tcLookupLocalValueOK "tcMonoBinds" name     `thenNF_Tc` \ id ->
 433     tcMatchesFun name (idType id) matches       `thenTc` \ (matches', lie) ->
 434     returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection{Signatures}
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 @tcSigs@ checks the signatures for validity, and returns a list of
 444 {\em freshly-instantiated} signatures.  That is, the types are already
 445 split up, and have fresh type variables installed.  All non-type-signature
 446 "RenamedSigs" are ignored.
 447
 448 \begin{code}
 449 tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
 450
 451 tcTySigs (Sig v ty _ src_loc : other_sigs)
 452  = tcAddSrcLoc src_loc (
 453         tcPolyType ty                   `thenTc` \ sigma_ty ->
 454         tcInstSigType sigma_ty          `thenNF_Tc` \ sigma_ty' ->
 455         let
 456             (tyvars', theta', tau') = splitSigmaTy sigma_ty'
 457         in
 458
 459         tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val ->
 460         unifyTauTy (idType val) tau'    `thenTc_`
 461
 462         returnTc (TySigInfo val tyvars' theta' tau' src_loc)
 463    )            `thenTc` \ sig_info1 ->
 464
 465    tcTySigs other_sigs  `thenTc` \ sig_infos ->
 466    returnTc (sig_info1 : sig_infos)
 467
 468 tcTySigs (other : sigs) = tcTySigs sigs
 469 tcTySigs []             = returnTc []
 470 \end{code}
 471
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection{SPECIALIZE pragmas}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479
 480 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
 481 pragmas.  It is convenient for them to appear in the @[RenamedSig]@
 482 part of a binding because then the same machinery can be used for
 483 moving them into place as is done for type signatures.
 484
 485 \begin{code}
 486 tcPragmaSigs :: [RenamedSig]                    -- The pragma signatures
 487              -> TcM s (Name -> PragmaInfo,      -- Maps name to the appropriate PragmaInfo
 488                        TcHsBinds s,
 489                        LIE s)
 490
 491 tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
 492
 493 {-
 494 tcPragmaSigs sigs
 495   = mapAndUnzip3Tc tcPragmaSig sigs     `thenTc` \ (names_w_id_infos, binds, lies) ->
 496     let
 497         name_to_info name = foldr ($) noIdInfo
 498                                   [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
 499     in
 500     returnTc (name_to_info,
 501               foldr ThenBinds EmptyBinds binds,
 502               foldr plusLIE emptyLIE lies)
 503 \end{code}
 504
 505 Here are the easy cases for tcPragmaSigs
 506
 507 \begin{code}
 508 tcPragmaSig (DeforestSig name loc)
 509   = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
 510 tcPragmaSig (InlineSig name loc)
 511   = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
 512 tcPragmaSig (MagicUnfoldingSig name string loc)
 513   = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
 514 \end{code}
 515
 516 The interesting case is for SPECIALISE pragmas.  There are two forms.
 517 Here's the first form:
 518 \begin{verbatim}
 519         f :: Ord a => [a] -> b -> b
 520         {-# SPECIALIZE f :: [Int] -> b -> b #-}
 521 \end{verbatim}
 522
 523 For this we generate:
 524 \begin{verbatim}
 525         f* = /\ b -> let d1 = ...
 526                      in f Int b d1
 527 \end{verbatim}
 528
 529 where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
 530 retain a right-hand-side that the simplifier will otherwise discard as
 531 dead code... the simplifier has a flag that tells it not to discard
 532 SpecPragmaId bindings.
 533
 534 In this case the f* retains a call-instance of the overloaded
 535 function, f, (including appropriate dictionaries) so that the
 536 specialiser will subsequently discover that there's a call of @f@ at
 537 Int, and will create a specialisation for @f@.  After that, the
 538 binding for @f*@ can be discarded.
 539
 540 The second form is this:
 541 \begin{verbatim}
 542         f :: Ord a => [a] -> b -> b
 543         {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
 544 \end{verbatim}
 545
 546 Here @g@ is specified as a function that implements the specialised
 547 version of @f@.  Suppose that g has type (a->b->b); that is, g's type
 548 is more general than that required.  For this we generate
 549 \begin{verbatim}
 550         f@Int = /\b -> g Int b
 551         f* = f@Int
 552 \end{verbatim}
 553
 554 Here @f@@Int@ is a SpecId, the specialised version of @f@.  It inherits
 555 f's export status etc.  @f*@ is a SpecPragmaId, as before, which just serves
 556 to prevent @f@@Int@ from being discarded prematurely.  After specialisation,
 557 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
 558 discard the f* binding.
 559
 560 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
 561 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
 562 a bit of overkill.
 563
 564 \begin{code}
 565 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 566   = tcAddSrcLoc src_loc                         $
 567     tcAddErrCtxt (valSpecSigCtxt name spec_ty)  $
 568
 569         -- Get and instantiate its alleged specialised type
 570     tcPolyType poly_ty                          `thenTc` \ sig_sigma ->
 571     tcInstSigType  sig_sigma                    `thenNF_Tc` \ sig_ty ->
 572     let
 573         (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
 574         origin = ValSpecOrigin name
 575     in
 576
 577         -- Check that the SPECIALIZE pragma had an empty context
 578     checkTc (null sig_theta)
 579             (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
 580
 581         -- Get and instantiate the type of the id mentioned
 582     tcLookupLocalValueOK "tcPragmaSig" name     `thenNF_Tc` \ main_id ->
 583     tcInstSigType [] (idType main_id)           `thenNF_Tc` \ main_ty ->
 584     let
 585         (main_tyvars, main_rho) = splitForAllTy main_ty
 586         (main_theta,main_tau)   = splitRhoTy main_rho
 587         main_arg_tys            = mkTyVarTys main_tyvars
 588     in
 589
 590         -- Check that the specialised type is indeed an instance of
 591         -- the type of the main function.
 592     unifyTauTy sig_tau main_tau         `thenTc_`
 593     checkSigTyVars sig_tyvars sig_tau   `thenTc_`
 594
 595         -- Check that the type variables of the polymorphic function are
 596         -- either left polymorphic, or instantiate to ground type.
 597         -- Also check that the overloaded type variables are instantiated to
 598         -- ground type; or equivalently that all dictionaries have ground type
 599     mapTc zonkTcType main_arg_tys       `thenNF_Tc` \ main_arg_tys' ->
 600     zonkTcThetaType main_theta          `thenNF_Tc` \ main_theta' ->
 601     tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
 602               (checkTc (all isGroundOrTyVarTy main_arg_tys'))           `thenTc_`
 603     tcAddErrCtxt (specContextGroundnessCtxt main_theta')
 604               (checkTc (and [isGroundTy ty | (_,ty) <- theta']))        `thenTc_`
 605
 606         -- Build the SpecPragmaId; it is the thing that makes sure we
 607         -- don't prematurely dead-code-eliminate the binding we are really interested in.
 608     newSpecPragmaId name sig_ty         `thenNF_Tc` \ spec_pragma_id ->
 609
 610         -- Build a suitable binding; depending on whether we were given
 611         -- a value (Maybe Name) to be used as the specialisation.
 612     case using of
 613       Nothing ->                -- No implementation function specified
 614
 615                 -- Make a Method inst for the occurrence of the overloaded function
 616         newMethodWithGivenTy (OccurrenceOf name)
 617                   (TcId main_id) main_arg_tys main_rho  `thenNF_Tc` \ (lie, meth_id) ->
 618
 619         let
 620             pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
 621             pseudo_rhs  = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
 622         in
 623         returnTc (pseudo_bind, lie, \ info -> info)
 624
 625       Just spec_name ->         -- Use spec_name as the specialisation value ...
 626
 627                 -- Type check a simple occurrence of the specialised Id
 628         tcId spec_name          `thenTc` \ (spec_body, spec_lie, spec_tau) ->
 629
 630                 -- Check that it has the correct type, and doesn't constrain the
 631                 -- signature variables at all
 632         unifyTauTy sig_tau spec_tau             `thenTc_`
 633         checkSigTyVars sig_tyvars sig_tau       `thenTc_`
 634
 635             -- Make a local SpecId to bind to applied spec_id
 636         newSpecId main_id main_arg_tys sig_ty   `thenNF_Tc` \ local_spec_id ->
 637
 638         let
 639             spec_rhs   = mkHsTyLam sig_tyvars spec_body
 640             spec_binds = VarMonoBind local_spec_id spec_rhs
 641                            `AndMonoBinds`
 642                          VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
 643             spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
 644         in
 645         returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
 646 -}
 647 \end{code}
 648
 649
 650 %************************************************************************
 651 %*                                                                      *
 652 \subsection[TcBinds-monomorphism]{The monomorphism restriction}
 653 %*                                                                      *
 654 %************************************************************************
 655
 656 Not exported:
 657
 658 \begin{code}
 659 isUnRestrictedGroup :: [TcIdBndr s]             -- Signatures given for these
 660                     -> TcBind s
 661                     -> Bool
 662
 663 isUnRestrictedGroup sigs EmptyBind              = True
 664 isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds
 665 isUnRestrictedGroup sigs (RecBind monobinds)    = isUnResMono sigs monobinds
 666
 667 is_elem v vs = isIn "isUnResMono" v vs
 668
 669 isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _)    = v `is_elem` sigs
 670 isUnResMono sigs (PatMonoBind other      _ _)           = False
 671 isUnResMono sigs (VarMonoBind (TcId v) _)               = v `is_elem` sigs
 672 isUnResMono sigs (FunMonoBind _ _ _ _)                  = True
 673 isUnResMono sigs (AndMonoBinds mb1 mb2)                 = isUnResMono sigs mb1 &&
 674                                                           isUnResMono sigs mb2
 675 isUnResMono sigs EmptyMonoBinds                         = True
 676 \end{code}
 677
 678
 679 %************************************************************************
 680 %*                                                                      *
 681 \subsection[TcBinds-errors]{Error contexts and messages}
 682 %*                                                                      *
 683 %************************************************************************
 684
 685
 686 \begin{code}
 687 patMonoBindsCtxt bind sty
 688   = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
 689
 690 --------------------------------------------
 691 specContextGroundnessCtxt -- err_ctxt dicts sty
 692   = panic "specContextGroundnessCtxt"
 693 {-
 694   = ppHang (
 695         ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
 696                ppBesides [ppStr " specialised to the type `", ppr sty spec_ty,  ppStr "'"],
 697                pp_spec_id sty,
 698                ppStr "... not all overloaded type variables were instantiated",
 699                ppStr "to ground types:"])
 700       4 (ppAboves [ppCat [ppr sty c, ppr sty t]
 701                   | (c,t) <- map getDictClassAndType dicts])
 702   where
 703     (name, spec_ty, locn, pp_spec_id)
 704       = case err_ctxt of
 705           ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> ppNil)
 706           ValSpecSpecIdCtxt n ty spec loc ->
 707             (n, ty, loc,
 708              \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
 709 -}
 710
 711 -----------------------------------------------
 712 specGroundnessCtxt
 713   = panic "specGroundnessCtxt"
 714
 715
 716 valSpecSigCtxt v ty sty
 717   = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
 718          4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")),
 719                   ppr sty ty])
 720 \end{code}
 721