TcBinds.lhs 59.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 5 6 7
%
\section[TcBinds]{TcBinds}

\begin{code}
8
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
9
                 tcHsBootSigs, tcPolyCheck,
10
                 PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
11
                 TcSigInfo(..), TcSigFun, 
12
                 instTcTySig, instTcTySigFromId, findScopedTyVars,
Ian Lynagh's avatar
Ian Lynagh committed
13
                 badBootDeclErr ) where
14

ross's avatar
ross committed
15
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
16
import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
Gergő Érdi's avatar
Gergő Érdi committed
17
import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl )
18

Simon Marlow's avatar
Simon Marlow committed
19 20
import DynFlags
import HsSyn
21
import HscTypes( isHsBoot )
22
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
23 24 25
import TcEnv
import TcUnify
import TcSimplify
26
import TcEvidence
Simon Marlow's avatar
Simon Marlow committed
27 28 29
import TcHsType
import TcPat
import TcMType
Gergő Érdi's avatar
Gergő Érdi committed
30 31
import PatSyn
import ConLike
Simon Peyton Jones's avatar
Simon Peyton Jones committed
32
import Type( tidyOpenType )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
33
import FunDeps( growThetaTyVars )
34
import TyCon
Simon Marlow's avatar
Simon Marlow committed
35 36 37
import TcType
import TysPrim
import Id
38
import Var
39
import VarSet
40
import Module
Simon Marlow's avatar
Simon Marlow committed
41
import Name
42
import NameSet
43
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
44
import SrcLoc
45
import Bag
46
import ListSetOps
Simon Marlow's avatar
Simon Marlow committed
47 48 49 50 51
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
52
import Outputable
53
import FastString
54 55 56
import Type(mkStrLitTy)
import Class(classTyCon)
import PrelNames(ipClassName)
57 58

import Control.Monad
59 60

#include "HsVersions.h"
61
\end{code}
62

63

64
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
65
%*                                                                      *
66
\subsection{Type-checking bindings}
Ian Lynagh's avatar
Ian Lynagh committed
67
%*                                                                      *
68 69
%************************************************************************

70
@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
71 72 73 74 75 76 77 78 79 80
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them.  So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
the scope of the bindings returning a typechecked thing and (most
important) an LIE.  It is this LIE which is then used as the basis for
specialising the things bound.

@tcBindsAndThen@ also takes a "combiner" which glues together the
bindings and the "thing" to make a new "thing".

81
The real work is done by @tcBindWithSigsAndThen@.
82 83 84 85 86 87 88 89 90 91

Recursive and non-recursive binds are handled in essentially the same
way: because of uniques there are no scoping issues left.  The only
difference is that non-recursive bindings can bind primitive values.

Even for non-recursive binding groups we add typings for each binder
to the LVE for the following reason.  When each individual binding is
checked the type of its LHS is unified with that of its RHS; and
type-checking the LHS of course requires that the binder is in scope.

92 93 94
At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
Note [Polymorphic recursion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is 

        * Bind any variable for which we have a type signature
          to an Id with a polymorphic type.  Then when type-checking 
          the RHSs we'll make a full polymorphic call.

This fine, but if you aren't a bit careful you end up with a horrendous
amount of partial application and (worse) a huge space leak. For example:

        f :: Eq a => [a] -> [a]
        f xs = ...f...

If we don't take care, after typechecking we get

        f = /\a -> \d::Eq a -> let f' = f a d
                               in
                               \ys:[a] -> ...f'...

Notice the the stupid construction of (f a d), which is of course
identical to the function we're executing.  In this case, the
polymorphic recursion isn't being used (but that's a very common case).
This can lead to a massive space leak, from the following top-level defn
(post-typechecking)

        ff :: [Int] -> [Int]
        ff = f Int dEqInt

Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
f' is another thunk which evaluates to the same thing... and you end
up with a chain of identical values all hung onto by the CAF ff.

        ff = f Int dEqInt

           = let f' = f Int dEqInt in \ys. ...f'...

           = let f' = let f' = f Int dEqInt in \ys. ...f'...
                      in \ys. ...f'...

Etc.

NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
which would make the space leak go away in this case

Solution: when typechecking the RHSs we always have in hand the
*monomorphic* Ids for each binding.  So we just need to make sure that
if (Method f a d) shows up in the constraints emerging from (...f...)
we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
to the "givens" when simplifying constraints.  That's what the "lies_avail"
is doing.

Then we get

        f = /\a -> \d::Eq a -> letrec
                                 fm = \ys:[a] -> ...fm...
                               in
                               fm

154
\begin{code}
155 156 157 158
tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
tcTopBinds (ValBindsOut binds sigs)
Gergő Érdi's avatar
Gergő Érdi committed
159 160 161 162 163
  = do  { -- Pattern synonym bindings populate the global environment
          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
            do { gbl <- getGblEnv
               ; lcl <- getLclEnv
               ; return (gbl, lcl) }
164 165 166 167 168 169 170 171
        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids

        ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd)
                                                       (tcg_binds tcg_env)
                                                       binds'
                                   , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } }

        ; return (tcg_env', tcl_env) }
Ian Lynagh's avatar
Ian Lynagh committed
172 173
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds
Gergő Érdi's avatar
Gergő Érdi committed
174

175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"

tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
tcRecSelBinds (ValBindsOut binds sigs)
  = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
    do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv)
       ; let tcg_env' 
              | isHsBoot (tcg_src tcg_env) = tcg_env
              | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd)
                                                        (tcg_binds tcg_env)
                                                        rec_sel_binds }
              -- Do not add the code for record-selector bindings when 
              -- compiling hs-boot files
       ; return tcg_env' }
tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
190

191
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
192 193
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it.  The renamer checked all this
194
tcHsBootSigs (ValBindsOut binds sigs)
Ian Lynagh's avatar
Ian Lynagh committed
195
  = do  { checkTc (null binds) badBootDeclErr
196
        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
197
  where
198 199 200 201
    tc_boot_sig (TypeSig lnames ty) = mapM f lnames
      where
        f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
                           ; return (mkVanillaGlobal name sigma_ty) }
Ian Lynagh's avatar
Ian Lynagh committed
202
        -- Notice that we make GlobalIds, not LocalIds
Ian Lynagh's avatar
Ian Lynagh committed
203
    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
204
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
205

206
badBootDeclErr :: MsgDoc
Ian Lynagh's avatar
Ian Lynagh committed
207
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
208

209 210
------------------------
tcLocalBinds :: HsLocalBinds Name -> TcM thing
Ian Lynagh's avatar
Ian Lynagh committed
211
             -> TcM (HsLocalBinds TcId, thing)
sof's avatar
sof committed
212

213
tcLocalBinds EmptyLocalBinds thing_inside 
Ian Lynagh's avatar
Ian Lynagh committed
214 215
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds, thing) }
sof's avatar
sof committed
216

217 218 219 220
tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside
  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
        ; return (HsValBinds (ValBindsOut binds' sigs), thing) }
tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
221

222
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
223 224 225
  = do  { ipClass <- tcLookupClass ipClassName
        ; (given_ips, ip_binds') <-
            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
226

Ian Lynagh's avatar
Ian Lynagh committed
227 228
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
229
        -- See Note [Implicit parameter untouchables]
230
        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
231
                                  [] given_ips thing_inside
232 233

        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
234
  where
235
    ips = [ip | L _ (IPBind (Left ip) _) <- ip_binds]
236

Ian Lynagh's avatar
Ian Lynagh committed
237 238 239
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
240
    tc_ip_bind ipClass (IPBind (Left ip) expr)
241
       = do { ty <- newFlexiTyVarTy openTypeKind
242 243
            ; let p = mkStrLitTy $ hsIPNameFS ip
            ; ip_id <- newDict ipClass [ p, ty ]
244
            ; expr' <- tcMonoExpr expr ty
245 246 247 248 249 250 251 252
            ; let d = toDict ipClass p ty `fmap` expr'
            ; return (ip_id, (IPBind (Right ip_id) d)) }
    tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"

    -- Coerces a `t` into a dictionry for `IP "x" t`.
    -- co : t -> IP "x" t
    toDict ipClass x ty =
      case unwrapNewTyCon_maybe (classTyCon ipClass) of
Joachim Breitner's avatar
Joachim Breitner committed
253
        Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty]
254 255 256
        Nothing       -> panic "The dictionary for `IP` is not a newtype?"


257
\end{code}
258

259 260 261 262 263 264 265 266
Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We add the type variables in the types of the implicit parameters
as untouchables, not so much because we really must not unify them,
but rather because we otherwise end up with constraints like this
    Num alpha, Implic { wanted = alpha ~ Int }
The constraint solver solves alpha~Int by unification, but then
doesn't float that solved constraint out (it's not an unsolved 
267
wanted).  Result disaster: the (Num alpha) is again solved, this
268 269
time by defaulting.  No no no.

270 271 272
However [Oct 10] this is all handled automatically by the 
untouchable-range idea.

273
\begin{code}
274
tcValBinds :: TopLevelFlag 
275 276 277
           -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
           -> TcM thing
           -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
278

279
tcValBinds top_lvl binds sigs thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
280
  = do  {       -- Typecheck the signature
281
          (poly_ids, sig_fn) <- tcTySigs sigs
Ian Lynagh's avatar
Ian Lynagh committed
282

283
        ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
Ian Lynagh's avatar
Ian Lynagh committed
284 285 286

                -- Extend the envt right away with all 
                -- the Ids declared with type signatures
287 288
                -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack
        ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
289
                             tcBindGroups top_lvl sig_fn prag_fn 
Ian Lynagh's avatar
Ian Lynagh committed
290 291
                                          binds thing_inside

292
        ; return (binds', thing) }
293

294
------------------------
295
tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
296 297
             -> [(RecFlag, LHsBinds Name)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
298 299
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
300 301 302
-- Here a "strongly connected component" has the strightforward
-- meaning of a group of bindings that mention each other, 
-- ignoring type signatures (that part comes later)
303

304
tcBindGroups _ _ _ [] thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
305 306
  = do  { thing <- thing_inside
        ; return ([], thing) }
307

308
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
309
  = do  { (group', (groups', thing))
310 311
                <- tc_group top_lvl sig_fn prag_fn group $ 
                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
312
        ; return (group' ++ groups', thing) }
sof's avatar
sof committed
313

314
------------------------
315
tc_group :: forall thing. 
316
            TopLevelFlag -> TcSigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
317 318
         -> (RecFlag, LHsBinds Name) -> TcM thing
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
319 320 321 322 323

-- Typecheck one strongly-connected component of the original program.
-- We get a list of groups back, because there may 
-- be specialisations etc as well

324
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
325 326
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
327
        -- so that we desugar unlifted bindings correctly
Gergő Érdi's avatar
Gergő Érdi committed
328 329 330 331 332 333
  = do { let bind = case bagToList binds of
                 [] -> panic "tc_group: empty list of binds"
                 [bind] -> bind
                 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
       ; return ( [(NonRecursive, bind')], thing) }
334 335

tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
336
  =     -- To maximise polymorphism, we do a new 
Ian Lynagh's avatar
Ian Lynagh committed
337 338
        -- strongly-connected-component analysis, this time omitting 
        -- any references to variables with type signatures.
339
        -- (This used to be optional, but isn't now.)
340
    do  { traceTc "tc_group rec" (pprLHsBinds binds)
Gergő Érdi's avatar
Gergő Érdi committed
341
        ; when hasPatSyn $ recursivePatSynErr binds
342
        ; (binds1, _ids, thing) <- go sccs
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
343 344
             -- Here is where we should do bindInstsOfLocalFuns
             -- if we start having Methods again
345
        ; return ([(Recursive, binds1)], thing) }
Ian Lynagh's avatar
Ian Lynagh committed
346
                -- Rec them all together
347
  where
348
    hasPatSyn = anyBag (isPatSyn . unLoc) binds
Gergő Érdi's avatar
Gergő Érdi committed
349 350 351
    isPatSyn PatSynBind{} = True
    isPatSyn _ = False

352
    sccs :: [SCC (LHsBind Name)]
353 354
    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)

355
    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
356
    go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
357
                        ; (binds2, ids2, thing)  <- tcExtendLetEnv top_lvl closed ids1 $ 
358
                                                    go sccs
359 360
                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
361

362 363
    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
sof's avatar
sof committed
364

365
    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
sof's avatar
sof committed
366

Gergő Érdi's avatar
Gergő Érdi committed
367 368 369 370
recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
recursivePatSynErr binds
  = failWithTc $
    hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
371
       2 (vcat $ map pprLBind . bagToList $ binds)
Gergő Érdi's avatar
Gergő Érdi committed
372 373 374 375 376 377 378
  where
    pprLoc loc  = parens (ptext (sLit "defined at") <+> ppr loc)
    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
                            pprLoc loc

tc_single :: forall thing.
            TopLevelFlag -> TcSigFun -> PragFun
379
          -> LHsBind Name -> TcM thing
Gergő Érdi's avatar
Gergő Érdi committed
380
          -> TcM (LHsBinds TcId, thing)
381
tc_single _top_lvl _sig_fn _prag_fn (L _ ps@PatSynBind{}) thing_inside
Gergő Érdi's avatar
Gergő Érdi committed
382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
  = do { (pat_syn, aux_binds) <-
              tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps)

       ; let tything = AConLike (PatSynCon pat_syn)
             implicit_ids = (patSynMatcher pat_syn) :
                            (maybeToList (patSynWrapper pat_syn))

       ; thing <- tcExtendGlobalEnv [tything] $
                  tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
                  thing_inside
       ; return (aux_binds, thing)
       }
tc_single top_lvl sig_fn prag_fn lbind thing_inside
  = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
                                    NonRecursive NonRecursive
                                    [lbind]
       ; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
       ; return (binds1, thing) }
          
401
------------------------
402
mkEdges :: TcSigFun -> LHsBinds Name
403
        -> [(LHsBind Name, BKey, [BKey])]
404 405 406 407

type BKey  = Int -- Just number off the bindings

mkEdges sig_fn binds
408
  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Ian Lynagh's avatar
Ian Lynagh committed
409
                         Just key <- [lookupNameEnv key_map n], no_sig n ])
410 411 412 413 414 415 416 417
    | (bind, key) <- keyd_binds
    ]
  where
    no_sig :: Name -> Bool
    no_sig n = isNothing (sig_fn n)

    keyd_binds = bagToList binds `zip` [0::BKey ..]

Ian Lynagh's avatar
Ian Lynagh committed
418
    key_map :: NameEnv BKey     -- Which binding it comes from
419
    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
Ian Lynagh's avatar
Ian Lynagh committed
420
                                     , bndr <- bindersOfHsBind bind ]
421 422

bindersOfHsBind :: HsBind Name -> [Name]
Gergő Érdi's avatar
Gergő Érdi committed
423 424 425 426 427
bindersOfHsBind (PatBind { pat_lhs = pat })           = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f })          = [f]
bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn]
bindersOfHsBind (AbsBinds {})                         = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {})                          = panic "bindersOfHsBind VarBind"
428

429
------------------------
430
tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
431 432 433
            -> RecFlag       -- Whether the group is really recursive
            -> RecFlag       -- Whether it's recursive after breaking
                             -- dependencies based on type signatures
434
            -> [LHsBind Name]
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
435
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
436 437 438 439 440

-- Typechecks a single bunch of bindings all together, 
-- and generalises them.  The bunch may be only part of a recursive
-- group, because we use type signatures to maximise polymorphism
--
441 442 443
-- Returns a list because the input may be a single non-recursive binding,
-- in which case the dependency order of the resulting bindings is
-- important.  
444
-- 
445 446
-- Knows nothing about the scope of the bindings

447 448
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
  = setSrcSpan loc                              $
Ian Lynagh's avatar
Ian Lynagh committed
449
    recoverM (recoveryCode binder_names sig_fn) $ do 
450
        -- Set up main recover; take advantage of any type sigs
451

452
    { traceTc "------------------------------------------------" empty
453
    ; traceTc "Bindings for {" (ppr binder_names)
454
    ; dflags   <- getDynFlags
455 456
    ; type_env <- getLclTypeEnv
    ; let plan = decideGeneralisationPlan dflags type_env 
457
                         binder_names bind_list sig_fn
458
    ; traceTc "Generalisation plan" (ppr plan)
459
    ; result@(tc_binds, poly_ids, _) <- case plan of
Gergő Érdi's avatar
Gergő Érdi committed
460 461 462
         NoGen               -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
         InferGen mn cl      -> tcPolyInfer rec_tc prag_fn sig_fn mn cl bind_list
         CheckGen lbind sig  -> tcPolyCheck rec_tc prag_fn sig lbind
463

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
464
        -- Check whether strict bindings are ok
Ian Lynagh's avatar
Ian Lynagh committed
465 466
        -- These must be non-recursive etc, and are not generalised
        -- They desugar to a case expression in the end
467 468 469 470
    ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
                                          ])
471

472
    ; return result }
473
  where
474 475
    binder_names = collectHsBindListBinders bind_list
    loc = foldr1 combineSrcSpans (map getLoc bind_list)
476 477
         -- The mbinds have been dependency analysed and 
         -- may no longer be adjacent; so find the narrowest
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
478
         -- span that includes them all
479

480
------------------
481
tcPolyNoGen     -- No generalisation whatsoever
482
  :: RecFlag       -- Whether it's recursive after breaking
483
                   -- dependencies based on type signatures
484
  -> PragFun -> TcSigFun
485
  -> [LHsBind Name]
486
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
487

488 489
tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
490 491
                                             (LetGblBndr prag_fn) 
                                             bind_list
492
       ; mono_ids' <- mapM tc_mono_info mono_infos
493
       ; return (binds', mono_ids', NotTopLevel) }
494 495
  where
    tc_mono_info (name, _, mono_id)
496
      = do { mono_ty' <- zonkTcType (idType mono_id)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
497
             -- Zonk, mainly to expose unboxed types to checkStrictBinds
498
           ; let mono_id' = setIdType mono_id mono_ty'
499
           ; _specs <- tcSpecPrags mono_id' (prag_fn name)
500
           ; return mono_id' }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
501 502 503 504
           -- NB: tcPrags generates error messages for
           --     specialisation pragmas for non-overloaded sigs
           -- Indeed that is why we call it here!
           -- So we can safely ignore _specs
505 506

------------------
507
tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
508
                             -- dependencies based on type signatures
509
            -> PragFun -> TcSigInfo 
510
            -> LHsBind Name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
511
            -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
512 513 514
-- There is just one binding, 
--   it binds a single variable,
--   it has a signature,
515
tcPolyCheck rec_tc prag_fn
516
            sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped 
517
                           , sig_theta = theta, sig_tau = tau, sig_loc = loc })
518
            bind
519
  = do { ev_vars <- newEvVars theta
520 521
       ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
             prag_sigs = prag_fn (idName poly_id)
522
             tvs = map snd tvs_w_scoped
523
       ; (ev_binds, (binds', [mono_info])) 
524 525 526
            <- setSrcSpan loc $  
               checkConstraints skol_info tvs ev_vars $
               tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
Gergő Érdi's avatar
Gergő Érdi committed
527
               tcMonoBinds rec_tc (\_ -> Just sig) LetLclBndr [bind]
528

529 530
       ; spec_prags <- tcSpecPrags poly_id prag_sigs
       ; poly_id    <- addInlinePrags poly_id prag_sigs
531

532 533 534 535 536
       ; let (_, _, mono_id) = mono_info
             export = ABE { abe_wrap = idHsWrapper
                          , abe_poly = poly_id
                          , abe_mono = mono_id
                          , abe_prags = SpecPrags spec_prags }
537 538 539 540
             abs_bind = L loc $ AbsBinds 
                        { abs_tvs = tvs
                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
                        , abs_exports = [export], abs_binds = binds' }
541 542
             closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
                    | otherwise                                     = NotTopLevel
543
       ; return (unitBag abs_bind, [poly_id], closed) }
544

545
------------------
546
tcPolyInfer 
547
  :: RecFlag       -- Whether it's recursive after breaking
548
                   -- dependencies based on type signatures
549 550 551
  -> PragFun -> TcSigFun 
  -> Bool         -- True <=> apply the monomorphism restriction
  -> Bool         -- True <=> free vars have closed types
552
  -> [LHsBind Name]
553
  -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
554
tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
555
  = do { ((binds', mono_infos), wanted)
556
             <- captureConstraints $
557
                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
558

559
       ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
560
       ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
561
       ; (qtvs, givens, mr_bites, ev_binds) <- 
562
                          simplifyInfer closed mono name_taus wanted
563

564 565
       ; theta <- zonkTcThetaType (map evVarPred givens)
       ; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
566 567

       ; loc <- getSrcSpanM
568
       ; let poly_ids = map abe_poly exports
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
569 570
             final_closed | closed && not mr_bites = TopLevel
                          | otherwise              = NotTopLevel
571 572 573 574
             abs_bind = L loc $ 
                        AbsBinds { abs_tvs = qtvs
                                 , abs_ev_vars = givens, abs_ev_binds = ev_binds
                                 , abs_exports = exports, abs_binds = binds' }
575

Simon Peyton Jones's avatar
Simon Peyton Jones committed
576 577
       ; traceTc "Binding:" (ppr final_closed $$
                             ppr (poly_ids `zip` map idType poly_ids))
578
       ; return (unitBag abs_bind, poly_ids, final_closed) }
579
         -- poly_ids are guaranteed zonked by mkExport
580 581

--------------
582
mkExport :: PragFun
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
583
         -> [TyVar] -> TcThetaType      -- Both already zonked
Ian Lynagh's avatar
Ian Lynagh committed
584
         -> MonoBindInfo
585
         -> TcM (ABExport Id)
586 587 588 589
-- Only called for generalisation plan IferGen, not by CheckGen or NoGen
--
-- mkExport generates exports with
--      zonked type variables,
Ian Lynagh's avatar
Ian Lynagh committed
590
--      zonked poly_ids
591 592 593 594
-- The former is just because no further unifications will change
-- the quantified type variables, so we can fix their final form
-- right now.
-- The latter is needed because the poly_ids are used to extend the
595
-- type environment; see the invariant on TcEnv.tcExtendIdEnv
596

597
-- Pre-condition: the qtvs and theta are already zonked
598

599
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
600
  = do  { mono_ty <- zonkTcType (idType mono_id)
601
        ; let poly_id  = case mb_sig of
602 603 604
                           Nothing  -> mkLocalId poly_name inferred_poly_ty
                           Just sig -> sig_id sig
                -- poly_id has a zonked type
605

606 607 608
              -- In the inference case (no signature) this stuff figures out
              -- the right type variables and theta to quantify over
              -- See Note [Impedence matching]
609 610
              my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty))
                            -- Include kind variables!  Trac #7916
611 612
              my_tvs   = filter (`elemVarSet` my_tvs2) qtvs   -- Maintain original order
              my_theta = filter (quantifyPred my_tvs2) theta
613 614
              inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty

615
        ; poly_id <- addInlinePrags poly_id prag_sigs
616
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
Ian Lynagh's avatar
Ian Lynagh committed
617
                -- tcPrags requires a zonked poly_id
618

619
        ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
620 621
        ; traceTc "mkExport: check sig"
                  (ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id))
622

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
623 624 625
        -- Perform the impedence-matching and ambiguity check
        -- right away.  If it fails, we want to fail now (and recover
        -- in tcPolyBinds).  If we delay checking, we get an error cascade.
626
        -- Remember we are in the tcPolyInfer case, so the type envt is
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
627 628
        -- closed (unless we are doing NoMonoLocalBinds in which case all bets
        -- are off)
629
        -- See Note [Impedence matching]
630 631 632
        ; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
                            captureConstraints $
                            tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
633
        ; ev_binds <- simplifyTop wanted
634 635 636 637 638

        ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
                      , abe_poly = poly_id
                      , abe_mono = mono_id
                      , abe_prags = SpecPrags spec_prags }) }
639
  where
640
    inferred = isNothing mb_sig
641

642 643 644 645 646 647 648 649 650 651 652
    mk_msg poly_id tidy_env
      = return (tidy_env', msg)
      where
        msg | inferred  = hang (ptext (sLit "When checking that") <+> pp_name)
                             2 (ptext (sLit "has the inferred type") <+> pp_ty)
                          $$ ptext (sLit "Probable cause: the inferred type is ambiguous")
            | otherwise = hang (ptext (sLit "When checking that") <+> pp_name)
                             2 (ptext (sLit "has the specified type") <+> pp_ty)
        pp_name = quotes (ppr poly_name)
        pp_ty   = quotes (ppr tidy_ty)
        (tidy_env', tidy_ty) = tidyOpenType tidy_env (idType poly_id)
653

654
    prag_sigs = prag_fn poly_name
655
    origin    = AmbigOrigin sig_ctxt
656
    sig_ctxt  = InfSigCtxt poly_name
657
\end{code}
658

659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698
Note [Impedence matching]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f 0 x = x
   f n x = g [] (not x)

   g [] y = f 10 y
   g _  y = f 9  y

After typechecking we'll get
  f_mono_ty :: a -> Bool -> Bool   
  g_mono_ty :: [b] -> Bool -> Bool 
with constraints
  (Eq a, Num a)

Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
The types we really want for f and g are
   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
   g :: forall b. [b] -> Bool -> Bool

We can get these by "impedence matching":
   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)

   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g

Suppose the shared quantified tyvars are qtvs and constraints theta.
Then we want to check that 
   f's polytype  is more polymorphic than   forall qtvs. theta => f_mono_ty
and the proof is the impedence matcher.  

Notice that the impedence matcher may do defaulting.  See Trac #7173.

It also cleverly does an ambiguity check; for example, rejecting
   f :: F a -> a
where F is a non-injective type function.


\begin{code}
699
type PragFun = Name -> [LSig Name]
700

701
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
702 703
mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
  where
Icelandjack's avatar
Icelandjack committed
704
    prs = mapMaybe get_sig sigs
705 706 707 708 709 710 711

    get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
    get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig  nm ty (add_arity nm inl))
    get_sig (L l (InlineSig nm inl))  = Just (nm, L l $ InlineSig nm   (add_arity nm inl))
    get_sig _                         = Nothing

    add_arity (L _ n) inl_prag   -- Adjust inl_sat field to match visible arity of function
712 713 714
      | Just ar <- lookupNameEnv ar_env n,
        Inline <- inl_inline inl_prag     = inl_prag { inl_sat = Just ar }
        -- add arity only for real INLINE pragmas, not INLINABLE
715 716 717 718 719 720 721 722
      | otherwise                         = inl_prag

    prag_env :: NameEnv [LSig Name]
    prag_env = foldl add emptyNameEnv prs
    add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p

    -- ar_env maps a local to the arity of its definition
    ar_env :: NameEnv Arity
723
    ar_env = foldrBag lhsBindArity emptyNameEnv binds
724 725 726 727

lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
  = extendNameEnv env (unLoc id) (matchGroupArity ms)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
728
lhsBindArity _ env = env        -- PatBind/VarBind
729

730
------------------
731 732
tcSpecPrags :: Id -> [LSig Name]
            -> TcM [LTcSpecPrag]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
733
-- Add INLINE and SPECIALSE pragmas
734 735
--    INLINE prags are added to the (polymorphic) Id directly
--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
Simon Marlow's avatar
Simon Marlow committed
736 737
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
738
tcSpecPrags poly_id prag_sigs
739 740
  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
       ; unless (null bad_sigs) warn_discarded_sigs
741
       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
742
  where
743 744 745 746
    spec_sigs = filter isSpecLSig prag_sigs
    bad_sigs  = filter is_bad_sig prag_sigs
    is_bad_sig s = not (isSpecLSig s || isInlineLSig s)

747 748 749 750 751 752
    warn_discarded_sigs = warnPrags poly_id bad_sigs $
                          ptext (sLit "Discarding unexpected pragmas for")


--------------
tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
753 754
tcSpec poly_id prag@(SpecSig fun_name hs_ty inl) 
  -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
755 756
  -- Example: SPECIALISE for a class method: the Name in the SpecSig is
  --          for the selector Id, but the poly_id is something like $cop
757 758
  -- However we want to use fun_name in the error message, since that is
  -- what the user wrote (Trac #8537)
759 760
  = addErrCtxt (spec_ctxt prag) $
    do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
761
        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
762
                 (ptext (sLit "SPECIALISE pragma for non-overloaded function") 
763
                  <+> quotes (ppr fun_name))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
764
                  -- Note [SPECIALISE pragmas]
765
        ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
766 767
        ; return (SpecPrag poly_id wrap inl) }
  where
768 769 770
    name      = idName poly_id
    poly_ty   = idType poly_id
    origin    = SpecPragOrigin name
771 772
    sig_ctxt  = FunSigCtxt name
    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
773

774
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
775

776 777
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
778
-- SPECIALISE pragamas for imported things
779 780
tcImpPrags prags
  = do { this_mod <- getModule
781
       ; dflags <- getDynFlags
782 783
       ; if (not_specialising dflags) then
            return []
784 785 786 787
         else
            mapAndRecoverM (wrapLocM tcImpSpec) 
            [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
                               , not (nameIsLocalOrFrom this_mod name) ] }
788 789 790 791 792 793
  where
    -- Ignore SPECIALISE pragmas for imported things
    -- when we aren't specialising, or when we aren't generating
    -- code.  The latter happens when Haddocking the base library;
    -- we don't wnat complaints about lack of INLINABLE pragmas 
    not_specialising dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
794
      | not (gopt Opt_Specialise dflags) = True
795 796 797 798
      | otherwise = case hscTarget dflags of
                      HscNothing -> True
                      HscInterpreted -> True
                      _other         -> False
799 800 801

tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
802
 = do { id <- tcLookupId name
803 804
      ; unless (isAnyInlinePragma (idInlinePragma id))
               (addWarnTc (impSpecErr name))
805 806 807 808 809
      ; tcSpec id prag }

impSpecErr :: Name -> SDoc
impSpecErr name
  = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
810
       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
811 812 813 814 815
               , parens $ sep 
                   [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
                   , ptext (sLit "was compiled without -O")]])
  where
    mod = nameModule name
816 817

--------------
818
tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
819 820
tcVectDecls decls 
  = do { decls' <- mapM (wrapLocM tcVect) decls
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
821
       ; let ids  = [lvectDeclName decl | decl <- decls', not $ lvectInstDecl decl]
822 823
             dups = findDupsEq (==) ids
       ; mapM_ reportVectDups dups
824
       ; traceTcConstraints "End of tcVectDecls"
825 826 827 828 829 830 831 832 833 834
       ; return decls'
       }
  where
    reportVectDups (first:_second:_more) 
      = addErrAt (getSrcSpan first) $
          ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first
    reportVectDups _ = return ()

--------------
tcVect :: VectDecl Name -> TcM (VectDecl TcId)
835 836 837
-- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
--   type of the original definition as this requires internals of the vectoriser not available
--   during type checking.  Instead, constrain the rhs of a vectorisation declaration to be a single
838 839
--   identifier (this is checked in 'rnHsVectDecl').  Fix this by enabling the use of 'vectType'
--   from the vectoriser here.
840
tcVect (HsVect name rhs)
841 842
  = addErrCtxt (vectCtxt name) $
    do { var <- wrapLocM tcLookupId name
843 844
       ; let L rhs_loc (HsVar rhs_var_name) = rhs
       ; rhs_id <- tcLookupId rhs_var_name
845
       ; return $ HsVect var (L rhs_loc (HsVar rhs_id))
846
       }
847

848
{- OLD CODE:
849
         -- turn the vectorisation declaration into a single non-recursive binding
850
       ; let bind    = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] 
851 852 853 854
             sigFun  = const Nothing
             pragFun = mkPragFun [] (unitBag bind)

         -- perform type inference (including generalisation)
855
       ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
856
       
857
       ; traceTc "tcVect inferred type" $ ppr (varType id')
858
       ; traceTc "tcVect bindings"      $ ppr binds
859
       
860 861
         -- add all bindings, including the type variable and dictionary bindings produced by type
         -- generalisation to the right-hand side of the vectorisation declaration
862 863 864 865 866 867 868 869 870 871 872
       ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
       ; let [bind']                                  = bagToList actualBinds
             MatchGroup 
               [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))]
               _                                      = (fun_matches . unLoc) bind'
             rhsWrapped                               = mkHsLams tvs evs (mkHsDictLet evBinds rhs')
        
        -- We return the type-checked 'Id', to propagate the inferred signature
        -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
       ; return $ HsVect (L loc id') (Just rhsWrapped)
       }
873
 -}
874 875
tcVect (HsNoVect name)
  = addErrCtxt (vectCtxt name) $
876 877
    do { var <- wrapLocM tcLookupId name
       ; return $ HsNoVect var