TcBinds.lhs 51 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, 
9
                 tcHsBootSigs, tcPolyBinds,
10
                 PragFun, tcSpecPrags, tcVectDecls, mkPragFun, 
11
                 TcSigInfo(..), SigFun, mkSigFun,
Ian Lynagh's avatar
Ian Lynagh committed
12
                 badBootDeclErr ) where
13

ross's avatar
ross committed
14
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
15
import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
16

Simon Marlow's avatar
Simon Marlow committed
17
18
import DynFlags
import HsSyn
19

20
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
21
22
23
24
25
26
27
import TcEnv
import TcUnify
import TcSimplify
import TcHsType
import TcPat
import TcMType
import TcType
28
import Coercion
Simon Marlow's avatar
Simon Marlow committed
29
30
import TysPrim
import Id
31
import Var
Simon Marlow's avatar
Simon Marlow committed
32
import Name
33
import NameSet
34
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
35
import SrcLoc
36
import Bag
37
import ListSetOps
Simon Marlow's avatar
Simon Marlow committed
38
39
40
41
42
import ErrUtils
import Digraph
import Maybes
import Util
import BasicTypes
43
import Outputable
44
import FastString
45
46

import Control.Monad
47
48

#include "HsVersions.h"
49
\end{code}
50

51

52
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
53
%*                                                                      *
54
\subsection{Type-checking bindings}
Ian Lynagh's avatar
Ian Lynagh committed
55
%*                                                                      *
56
57
%************************************************************************

58
@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
59
60
61
62
63
64
65
66
67
68
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".

69
The real work is done by @tcBindWithSigsAndThen@.
70
71
72
73
74
75
76
77
78
79

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.

80
81
82
At the top-level the LIE is sure to contain nothing but constant
dictionaries, which we resolve at the module level.

83
\begin{code}
84
85
86
87
88
tcTopBinds :: HsValBinds Name 
           -> TcM ( LHsBinds TcId	-- Typechecked bindings
                  , [LTcSpecPrag]	-- SPECIALISE prags for imported Ids
                  , TcLclEnv)		-- Augmented environment

Ian Lynagh's avatar
Ian Lynagh committed
89
90
91
        -- Note: returning the TcLclEnv is more than we really
        --       want.  The bit we care about is the local bindings
        --       and the free type variables thereof
92
tcTopBinds binds
93
94
95
96
  = do  { (ValBindsOut prs sigs, env) <- tcValBinds TopLevel binds getLclEnv
        ; let binds = foldr (unionBags . snd) emptyBag prs
        ; specs <- tcImpPrags sigs
        ; return (binds, specs, env) }
Ian Lynagh's avatar
Ian Lynagh committed
97
98
        -- The top level bindings are flattened into a giant 
        -- implicitly-mutually-recursive LHsBinds
99

100
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
101
102
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it.  The renamer checked all this
103
tcHsBootSigs (ValBindsOut binds sigs)
Ian Lynagh's avatar
Ian Lynagh committed
104
  = do  { checkTc (null binds) badBootDeclErr
105
        ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
106
  where
107
    tc_boot_sig (TypeSig (L _ name) ty)
108
      = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
109
           ; return (mkVanillaGlobal name sigma_ty) }
Ian Lynagh's avatar
Ian Lynagh committed
110
        -- Notice that we make GlobalIds, not LocalIds
Ian Lynagh's avatar
Ian Lynagh committed
111
    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
112
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
113

114
badBootDeclErr :: Message
Ian Lynagh's avatar
Ian Lynagh committed
115
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
116

117
118
------------------------
tcLocalBinds :: HsLocalBinds Name -> TcM thing
Ian Lynagh's avatar
Ian Lynagh committed
119
             -> TcM (HsLocalBinds TcId, thing)
sof's avatar
sof committed
120

121
tcLocalBinds EmptyLocalBinds thing_inside 
Ian Lynagh's avatar
Ian Lynagh committed
122
123
  = do  { thing <- thing_inside
        ; return (EmptyLocalBinds, thing) }
sof's avatar
sof committed
124

125
tcLocalBinds (HsValBinds binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
126
127
  = do  { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
        ; return (HsValBinds binds', thing) }
128

129
tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
130
  = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
131

Ian Lynagh's avatar
Ian Lynagh committed
132
133
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
134
        -- See Note [Implicit parameter untouchables]
135
        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
136
                                  [] given_ips thing_inside
137
138

        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
139
  where
140
141
    ips = [ip | L _ (IPBind ip _) <- ip_binds]

Ian Lynagh's avatar
Ian Lynagh committed
142
143
144
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
145
146
147
148
149
    tc_ip_bind (IPBind ip expr) 
       = do { ty <- newFlexiTyVarTy argTypeKind
            ; ip_id <- newIP ip ty
            ; expr' <- tcMonoExpr expr ty
            ; return (ip_id, (IPBind (IPName ip_id) expr')) }
150
\end{code}
151

152
153
154
155
156
157
158
159
160
161
162
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 
wanted.  Result disaster: the (Num alpha) is again solved, this
time by defaulting.  No no no.

163
164
165
However [Oct 10] this is all handled automatically by the 
untouchable-range idea.

166
\begin{code}
167
tcValBinds :: TopLevelFlag 
Ian Lynagh's avatar
Ian Lynagh committed
168
169
           -> HsValBinds Name -> TcM thing
           -> TcM (HsValBinds TcId, thing) 
170

Ian Lynagh's avatar
Ian Lynagh committed
171
tcValBinds _ (ValBindsIn binds _) _
172
173
  = pprPanic "tcValBinds" (ppr binds)

174
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
175
  = do  {       -- Typecheck the signature
176
        ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
177
              ; ty_sigs = filter isTypeLSig sigs
178
              ; sig_fn  = mkSigFun ty_sigs }
Ian Lynagh's avatar
Ian Lynagh committed
179

180
        ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
Ian Lynagh's avatar
Ian Lynagh committed
181
182
183
184
185
186
187
188
189
                -- No recovery from bad signatures, because the type sigs
                -- may bind type variables, so proceeding without them
                -- can lead to a cascade of errors
                -- ToDo: this means we fall over immediately if any type sig
                -- is wrong, which is over-conservative, see Trac bug #745

                -- Extend the envt right away with all 
                -- the Ids declared with type signatures
        ; (binds', thing) <- tcExtendIdEnv poly_ids $
190
                             tcBindGroups top_lvl sig_fn prag_fn 
Ian Lynagh's avatar
Ian Lynagh committed
191
192
193
                                          binds thing_inside

        ; return (ValBindsOut binds' sigs, thing) }
194

195
------------------------
196
tcBindGroups :: TopLevelFlag -> SigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
197
198
             -> [(RecFlag, LHsBinds Name)] -> TcM thing
             -> TcM ([(RecFlag, LHsBinds TcId)], thing)
199
200
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
201
202
203
-- 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)
204

205
tcBindGroups _ _ _ [] thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
206
207
  = do  { thing <- thing_inside
        ; return ([], thing) }
208

209
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
210
  = do  { (group', (groups', thing))
211
212
                <- 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
213
        ; return (group' ++ groups', thing) }
sof's avatar
sof committed
214

215
------------------------
216
217
tc_group :: forall thing. 
            TopLevelFlag -> SigFun -> PragFun
Ian Lynagh's avatar
Ian Lynagh committed
218
219
         -> (RecFlag, LHsBinds Name) -> TcM thing
         -> TcM ([(RecFlag, LHsBinds TcId)], thing)
220
221
222
223
224

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

225
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
Ian Lynagh's avatar
Ian Lynagh committed
226
227
        -- A single non-recursive binding
        -- We want to keep non-recursive things non-recursive
228
        -- so that we desugar unlifted bindings correctly
229
230
231
232
233
234
235
 =  do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn NonRecursive NonRecursive
                                      (bagToList binds)
       ; thing <- tcExtendIdEnv ids thing_inside
       ; return ( [(NonRecursive, binds1)], thing) }

tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
  =     -- To maximise polymorphism (assumes -XRelaxedPolyRec), we do a new 
Ian Lynagh's avatar
Ian Lynagh committed
236
237
        -- strongly-connected-component analysis, this time omitting 
        -- any references to variables with type signatures.
238
239
240
241
242
    do  { traceTc "tc_group rec" (pprLHsBinds binds)
        ; (binds1, _ids, thing) <- go sccs
    	     -- Here is where we should do bindInstsOfLocalFuns
	     -- if we start having Methods again
        ; return ([(Recursive, binds1)], thing) }
Ian Lynagh's avatar
Ian Lynagh committed
243
                -- Rec them all together
244
  where
245
246
247
248
249
    sccs :: [SCC (LHsBind Name)]
    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)

    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
    go (scc:sccs) = do  { (binds1, ids1)        <- tc_scc scc
Ian Lynagh's avatar
Ian Lynagh committed
250
                        ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs
251
252
                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
253

254
255
    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
sof's avatar
sof committed
256

257
    tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
sof's avatar
sof committed
258

259
260

------------------------
261
{-
262
bindLocalInsts :: TopLevelFlag
263
264
	       -> TcM (LHsBinds TcId, [TcId],    a)
	       -> TcM (LHsBinds TcId, TcEvBinds, a)
265
bindLocalInsts top_lvl thing_inside
266
267
  | isTopLevel top_lvl
  = do { (binds, _, thing) <- thing_inside; return (binds, emptyBag, thing) }
Ian Lynagh's avatar
Ian Lynagh committed
268
269
270
        -- For the top level don't bother with all this bindInstsOfLocalFuns stuff. 
        -- All the top level things are rec'd together anyway, so it's fine to
        -- leave them to the tcSimplifyTop, and quite a bit faster too
271

Ian Lynagh's avatar
Ian Lynagh committed
272
  | otherwise   -- Nested case
273
  = do  { ((binds, ids, thing), lie) <- captureConstraints thing_inside
274
        ; lie_binds <- bindLocalMethods lie ids
275
        ; return (binds, lie_binds, thing) }
276
-}
277
278

------------------------
279
mkEdges :: SigFun -> LHsBinds Name
Ian Lynagh's avatar
Ian Lynagh committed
280
        -> [(LHsBind Name, BKey, [BKey])]
281
282
283
284

type BKey  = Int -- Just number off the bindings

mkEdges sig_fn binds
285
  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Ian Lynagh's avatar
Ian Lynagh committed
286
                         Just key <- [lookupNameEnv key_map n], no_sig n ])
287
288
289
290
291
292
293
294
    | (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
295
    key_map :: NameEnv BKey     -- Which binding it comes from
296
    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
Ian Lynagh's avatar
Ian Lynagh committed
297
                                     , bndr <- bindersOfHsBind bind ]
298
299

bindersOfHsBind :: HsBind Name -> [Name]
300
301
bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
Ian Lynagh's avatar
Ian Lynagh committed
302
303
bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
304

305
------------------------
306
307
308
309
310
311
tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun
  	    -> RecFlag       -- Whether the group is really recursive
  	    -> RecFlag       -- Whether it's recursive after breaking
  	                     -- dependencies based on type signatures
  	    -> [LHsBind Name]
  	    -> TcM (LHsBinds TcId, [TcId])
312
313
314
315
316

-- 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
--
317
318
319
-- 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.  
320
-- 
321
322
-- Knows nothing about the scope of the bindings

323
324
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
  = setSrcSpan loc                              $
Ian Lynagh's avatar
Ian Lynagh committed
325
    recoverM (recoveryCode binder_names sig_fn) $ do 
326
        -- Set up main recover; take advantage of any type sigs
327

328
329
    { traceTc "------------------------------------------------" empty
    ; traceTc "Bindings for" (ppr binder_names)
330

331
332
    -- Instantiate the polytypes of any binders that have signatures
    -- (as determined by sig_fn), returning a TcSigInfo for each
333
    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
334

335
336
337
338
    ; dflags <- getDOpts
    ; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn
    ; traceTc "Generalisation plan" (ppr plan)
    ; (binds, poly_ids) <- case plan of
339
340
341
         NoGen         -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
         InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list
         CheckGen sig  -> tcPolyCheck sig prag_fn rec_tc bind_list
342
343

	-- Check whether strict bindings are ok
Ian Lynagh's avatar
Ian Lynagh committed
344
345
        -- These must be non-recursive etc, and are not generalised
        -- They desugar to a case expression in the end
346
347
348
349
350
    ; checkStrictBinds top_lvl rec_group bind_list poly_ids

    ; return (binds, poly_ids) }
  where
    binder_names = collectHsBindListBinders bind_list
351
352
353
354
    loc = foldr1 combineSrcSpans (map getLoc bind_list)
         -- The mbinds have been dependency analysed and 
         -- may no longer be adjacent; so find the narrowest
	 -- span that includes them all
355

356
------------------
357
358
359
360
361
362
363
364
tcPolyNoGen 
  :: TcSigFun -> PragFun
  -> RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> [LHsBind Name]
  -> TcM (LHsBinds TcId, [TcId])
-- No generalisation whatsoever

365
366
367
tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
  = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn) 
                                             rec_tc bind_list
368
369
370
371
372
373
374
       ; mono_ids' <- mapM tc_mono_info mono_infos
       ; return (binds', mono_ids') }
  where
    tc_mono_info (name, _, mono_id)
      = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
      	     -- Zonk, mainly to expose unboxed types to checkStrictBinds
           ; let mono_id' = setIdType mono_id mono_ty'
375
           ; _specs <- tcSpecPrags mono_id' (prag_fn name)
376
377
           ; return mono_id' }
	   -- NB: tcPrags generates error messages for
378
	   --     specialisation pragmas for non-overloaded sigs
379
	   -- Indeed that is why we call it here!
380
381
382
383
384
385
386
387
388
389
390
391
	   -- So we can safely ignore _specs

------------------
tcPolyCheck :: TcSigInfo -> PragFun
  	    -> RecFlag       -- Whether it's recursive after breaking
  	                     -- dependencies based on type signatures
  	    -> [LHsBind Name]
  	    -> TcM (LHsBinds TcId, [TcId])
-- There is just one binding, 
--   it binds a single variable,
--   it has a signature,
tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
392
                           , sig_theta = theta, sig_tau = tau })
393
    prag_fn rec_tc bind_list
394
  = do { ev_vars <- newEvVars theta
395
       ; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau)
396
       ; (ev_binds, (binds', [mono_info])) 
397
            <- checkConstraints skol_info tvs ev_vars $
398
               tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs)    $
399
               tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
400

401
       ; export <- mkExport prag_fn tvs theta mono_info
402

403
       ; loc <- getSrcSpanM
404
405
406
407
408
409
410
       ; let (_, poly_id, _, _) = export
             abs_bind = L loc $ AbsBinds 
                        { abs_tvs = tvs
                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
                        , abs_exports = [export], abs_binds = binds' }
       ; return (unitBag abs_bind, [poly_id]) }

411
------------------
412
413
414
415
416
417
418
419
tcPolyInfer 
  :: TopLevelFlag 
  -> Bool	  -- True <=> apply the monomorphism restriction
  -> TcSigFun -> PragFun
  -> RecFlag       -- Whether it's recursive after breaking
                   -- dependencies based on type signatures
  -> [LHsBind Name]
  -> TcM (LHsBinds TcId, [TcId])
420
tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list
421
  = do { ((binds', mono_infos), wanted) 
422
             <- captureConstraints $
423
                tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
424
425
426

       ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] 

427
428
       ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
       ; (qtvs, givens, ev_binds) <- simplifyInfer top_lvl mono name_taus wanted
429

430
       ; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens))
431
432
433
434
435
436
437
438
439
440
441
442
                    mono_infos

       ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))

       ; loc <- getSrcSpanM
       ; let abs_bind = L loc $ AbsBinds { abs_tvs = qtvs
                                         , abs_ev_vars = givens, abs_ev_binds = ev_binds
                                         , abs_exports = exports, abs_binds = binds' }

       ; return (unitBag abs_bind, poly_ids)   -- poly_ids are guaranteed zonked by mkExport
  }
443
444
445


--------------
446
mkExport :: PragFun -> [TyVar] -> TcThetaType
Ian Lynagh's avatar
Ian Lynagh committed
447
         -> MonoBindInfo
448
         -> TcM ([TyVar], Id, Id, TcSpecPrags)
449
-- mkExport generates exports with 
Ian Lynagh's avatar
Ian Lynagh committed
450
451
--      zonked type variables, 
--      zonked poly_ids
452
453
454
455
456
457
458
459
-- 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
-- type environment; see the invariant on TcEnv.tcExtendIdEnv 

-- Pre-condition: the inferred_tvs are already zonked

460
mkExport prag_fn inferred_tvs theta
461
         (poly_name, mb_sig, mono_id)
462
  = do  { (tvs, poly_id) <- mk_poly_id mb_sig
Ian Lynagh's avatar
Ian Lynagh committed
463
                -- poly_id has a zonked type
464

465
466
        ; poly_id' <- addInlinePrags poly_id prag_sigs

467
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
Ian Lynagh's avatar
Ian Lynagh committed
468
                -- tcPrags requires a zonked poly_id
469

470
        ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) }
471
  where
472
    prag_sigs = prag_fn poly_name
473
    poly_ty = mkSigmaTy inferred_tvs theta (idType mono_id)
474

475
476
477
478
    mk_poly_id Nothing    = do { poly_ty' <- zonkTcTypeCarefully poly_ty
                               ; return (inferred_tvs, mkLocalId poly_name poly_ty') }
    mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
                               ; return (tvs,  sig_id sig) }
479

480
    zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
481
482

------------------------
483
type PragFun = Name -> [LSig Name]
484

485
mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
486
487
488
489
490
491
492
493
494
495
mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
  where
    prs = mapCatMaybes get_sig sigs

    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
496
497
498
      | 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
499
500
501
502
503
504
505
506
507
508
509
510
511
512
      | 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
    ar_env = foldrBag lhsBindArity emptyNameEnv binds

lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
  = extendNameEnv env (unLoc id) (matchGroupArity ms)
lhsBindArity _ env = env	-- PatBind/VarBind
513

514
------------------
515
516
tcSpecPrags :: Id -> [LSig Name]
            -> TcM [LTcSpecPrag]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
517
-- Add INLINE and SPECIALSE pragmas
518
519
--    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
520
521
-- Pre-condition: the poly_id is zonked
-- Reason: required by tcSubExp
522
523
524
tcSpecPrags poly_id prag_sigs
  = do { unless (null bad_sigs) warn_discarded_sigs
       ; mapAndRecoverM (wrapLocM (tcSpec poly_id)) spec_sigs }
525
  where
526
527
528
529
    spec_sigs = filter isSpecLSig prag_sigs
    bad_sigs  = filter is_bad_sig prag_sigs
    is_bad_sig s = not (isSpecLSig s || isInlineLSig s)

530
531
532
533
534
535
536
537
538
539
540
541
    warn_discarded_sigs = warnPrags poly_id bad_sigs $
                          ptext (sLit "Discarding unexpected pragmas for")


--------------
tcSpec :: TcId -> Sig Name -> TcM TcSpecPrag
tcSpec poly_id prag@(SpecSig _ hs_ty inl) 
  -- The Name in the SpecSig may not be the same as that of the poly_id
  -- Example: SPECIALISE for a class method: the Name in the SpecSig is
  --          for the selector Id, but the poly_id is something like $cop
  = addErrCtxt (spec_ctxt prag) $
    do  { spec_ty <- tcHsSigType sig_ctxt hs_ty
542
543
544
        ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
                 (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
		  -- Note [SPECIALISE pragmas]
545
        ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
546
547
        ; return (SpecPrag poly_id wrap inl) }
  where
548
549
550
    name      = idName poly_id
    poly_ty   = idType poly_id
    origin    = SpecPragOrigin name
551
552
    sig_ctxt  = FunSigCtxt name
    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
553

554
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
555

556
557
558
559
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
tcImpPrags prags
  = do { this_mod <- getModule
560
561
562
563
564
565
       ; mapAndRecoverM (wrapLocM tcImpSpec) 
         [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
                            , not (nameIsLocalOrFrom this_mod name) ] }

tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
tcImpSpec (name, prag)
566
 = do { id <- tcLookupId name
567
      ; checkTc (isAnyInlinePragma (idInlinePragma id))
568
569
570
571
572
573
                (impSpecErr name)
      ; tcSpec id prag }

impSpecErr :: Name -> SDoc
impSpecErr name
  = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
574
       2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
               , ptext (sLit "(or you compiled its defining module without -O)")])

--------------
tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
tcVectDecls decls 
  = do { decls' <- mapM (wrapLocM tcVect) decls
       ; let ids  = [unLoc id | L _ (HsVect id _) <- decls']
             dups = findDupsEq (==) ids
       ; mapM_ reportVectDups dups
       ; 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)
-- 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, we infer the type of the expression and leave it to the vectoriser
-- to check the compatibility of the Core types.
tcVect (HsVect name Nothing)
  = addErrCtxt (vectCtxt name) $
    do { id <- wrapLocM tcLookupId name
       ; return (HsVect id Nothing)
       }
tcVect (HsVect name@(L loc _) (Just rhs))
  = addErrCtxt (vectCtxt name) $
    do { _id <- wrapLocM tcLookupId name     -- need to ensure that the name is already defined

         -- turn the vectorisation declaration into a single non-recursive binding
       ; let bind    = L loc $ mkFunBind name [mkSimpleMatch [] rhs] 
             sigFun  = const Nothing
             pragFun = mkPragFun [] (unitBag bind)

         -- perform type inference (including generalisation)
       ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]

       ; traceTc "tcVect inferred type" $ ppr (varType id')
       
         -- add the type variable and dictionary bindings produced by type generalisation to the
         -- right-hand side of the vectorisation declaration
       ; 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)
       }

vectCtxt :: Located Name -> SDoc
vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name

634
--------------
635
636
637
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise 
-- subsequent error messages
638
recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id])
639
recoveryCode binder_names sig_fn
640
  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
Ian Lynagh's avatar
Ian Lynagh committed
641
        ; poly_ids <- mapM mk_dummy binder_names
642
        ; return (emptyBag, poly_ids) }
643
  where
644
    mk_dummy name 
Ian Lynagh's avatar
Ian Lynagh committed
645
646
        | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
        | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
647
648

forall_a_a :: TcType
649
forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
650
651
\end{code}

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
Note [SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~
There is no point in a SPECIALISE pragma for a non-overloaded function:
   reverse :: [a] -> [a]
   {-# SPECIALISE reverse :: [Int] -> [Int] #-}

But SPECIALISE INLINE *can* make sense for GADTS:
   data Arr e where
     ArrInt :: !Int -> ByteArray# -> Arr Int
     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)

   (!:) :: Arr e -> Int -> e
   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}  
   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)

When (!:) is specialised it becomes non-recursive, and can usefully
be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
for a non-overloaded function.
672

673
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
674
%*                                                                      *
675
\subsection{tcMonoBind}
Ian Lynagh's avatar
Ian Lynagh committed
676
%*                                                                      *
677
678
%************************************************************************

679
@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
680
681
The signatures have been dealt with already.

682
\begin{code}
683
tcMonoBinds :: TcSigFun -> LetBndrSpec 
Ian Lynagh's avatar
Ian Lynagh committed
684
685
686
            -> RecFlag  -- Whether the binding is recursive for typechecking purposes
                        -- i.e. the binders are mentioned in their RHSs, and
                        --      we are not resuced by a type signature
687
            -> [LHsBind Name]
Ian Lynagh's avatar
Ian Lynagh committed
688
            -> TcM (LHsBinds TcId, [MonoBindInfo])
689

690
691
tcMonoBinds sig_fn no_gen is_rec
           [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
Ian Lynagh's avatar
Ian Lynagh committed
692
                                fun_matches = matches, bind_fvs = fvs })]
693
694
695
                             -- Single function binding, 
  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
  , Nothing <- sig_fn name   -- ...with no type signature
Ian Lynagh's avatar
Ian Lynagh committed
696
697
698
699
700
701
702
703
  =     -- In this very special case we infer the type of the
        -- right hand side first (it may have a higher-rank type)
        -- and *then* make the monomorphic Id for the LHS
        -- e.g.         f = \(x::forall a. a->a) -> <body>
        --      We want to infer a higher-rank type for f
    setSrcSpan b_loc    $
    do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)

704
        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
Ian Lynagh's avatar
Ian Lynagh committed
705
706
707
708
        ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
                                              fun_matches = matches', bind_fvs = fvs,
                                              fun_co_fn = co_fn, fun_tick = Nothing })),
                  [(name, Nothing, mono_id)]) }
709

710
711
tcMonoBinds sig_fn no_gen _ binds
  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
712

Ian Lynagh's avatar
Ian Lynagh committed
713
714
715
        -- Bring the monomorphic Ids, into scope for the RHSs
        ; let mono_info  = getMonoBindInfo tc_binds
              rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
716
717
                    -- A monomorphic binding for each term variable that lacks 
                    -- a type sig.  (Ones with a sig are already in scope.)
718

Ian Lynagh's avatar
Ian Lynagh committed
719
        ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
720
721
                    traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
                                                  | (n,id) <- rhs_id_env]
Ian Lynagh's avatar
Ian Lynagh committed
722
723
                    mapM (wrapLocM tcRhs) tc_binds
        ; return (listToBag binds', mono_info) }
724
725
726
727

------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
Ian Lynagh's avatar
Ian Lynagh committed
728
729
--      if there's a signature for it, use the instantiated signature type
--      otherwise invent a type variable
730
731
732
-- You see that quite directly in the FunBind case.
-- 
-- But there's a complication for pattern bindings:
Ian Lynagh's avatar
Ian Lynagh committed
733
734
--      data T = MkT (forall a. a->a)
--      MkT f = e
735
736
737
738
739
740
-- Here we can guess a type variable for the entire LHS (which will be refined to T)
-- but we want to get (f::forall a. a->a) as the RHS environment.
-- The simplest way to do this is to typecheck the pattern, and then look up the
-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't

Ian Lynagh's avatar
Ian Lynagh committed
741
data TcMonoBind         -- Half completed; LHS done, RHS not done
742
  = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name) 
743
744
  | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType

745
type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
Ian Lynagh's avatar
Ian Lynagh committed
746
747
        -- Type signature (if any), and
        -- the monomorphic bound things
748

749
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
750
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
751
752
753
754
755
756
757
  | Just sig <- sig_fn name
  = do  { mono_id <- newSigLetBndr no_gen name sig
        ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
  | otherwise
  = do  { mono_ty <- newFlexiTyVarTy argTypeKind
        ; mono_id <- newNoSigLetBndr no_gen name mono_ty
        ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
758
759
760
761

tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
  = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
                              mapM lookup_info (collectPatBinders pat)
Ian Lynagh's avatar
Ian Lynagh committed
762
763
764

                -- After typechecking the pattern, look up the binder
                -- names, which the pattern has brought into scope.
765
766
767
              lookup_info :: Name -> TcM MonoBindInfo
              lookup_info name = do { mono_id <- tcLookupId name
                                    ; return (name, sig_fn name, mono_id) }
Ian Lynagh's avatar
Ian Lynagh committed
768
769
770
771
772

        ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
                                     tcInfer tc_pat

        ; return (TcPatBind infos pat' grhss pat_ty) }
773

774
tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
Ian Lynagh's avatar
Ian Lynagh committed
775
        -- AbsBind, VarBind impossible
776

777
778
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
779
780
781
782
-- When we are doing pattern bindings, or multiple function bindings at a time
-- we *don't* bring any scoped type variables into scope
-- Wny not?  They are not completely rigid.
-- That's why we have the special case for a single FunBind in tcMonoBinds
783
tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
Ian Lynagh's avatar
Ian Lynagh committed
784
785
  = do  { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
                                            matches (idType mono_id)
786
787
        ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
                          , fun_matches = matches'
788
789
                          , fun_co_fn = co_fn 
                          , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
790

Ian Lynagh's avatar
Ian Lynagh committed
791
tcRhs (TcPatBind _ pat' grhss pat_ty)
Ian Lynagh's avatar
Ian Lynagh committed
792
793
  = do  { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
                    tcGRHSsPat grhss pat_ty
794
795
        ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
                          , bind_fvs = placeHolderNames }) }
796
797
798


---------------------
799
getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
800
getMonoBindInfo tc_binds
801
  = foldr (get_info . unLoc) [] tc_binds
802
803
804
805
806
807
808
  where
    get_info (TcFunBind info _ _ _)  rest = info : rest
    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
\end{code}


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
809
810
811
%*                                                                      *
                Generalisation
%*                                                                      *
812
813
%************************************************************************

814
815
816
unifyCtxts checks that all the signature contexts are the same
The type signatures on a mutually-recursive group of definitions
must all have the same context (or none).
817

818
819
820
821
822
823
824
825
826
The trick here is that all the signatures should have the same
context, and we want to share type variables for that context, so that
all the right hand sides agree a common vocabulary for their type
constraints

We unify them because, with polymorphic recursion, their types
might not otherwise be related.  This is a rather subtle issue.

\begin{code}
827
unifyCtxts :: [TcSigInfo] -> TcM ()
828
-- Post-condition: the returned Insts are full zonked
829
830
831
832
unifyCtxts [] = return ()
unifyCtxts (sig1 : sigs)
  = do  { traceTc "unifyCtxts" (ppr (sig1 : sigs))
	; mapM_ unify_ctxt sigs }
833
834
835
836
  where
    theta1 = sig_theta sig1
    unify_ctxt :: TcSigInfo -> TcM ()
    unify_ctxt sig@(TcSigInfo { sig_theta = theta })
837
        = setSrcSpan (sig_loc sig)                      $
Ian Lynagh's avatar
Ian Lynagh committed
838
839
840
841
842
843
844
845
846
          addErrCtxt (sigContextsCtxt sig1 sig)         $
          do { cois <- unifyTheta theta1 theta
             ; -- Check whether all coercions are identity coercions
               -- That can happen if we have, say
               --         f :: C [a]   => ...
               --         g :: C (F a) => ...
               -- where F is a type function and (F a ~ [a])
               -- Then unification might succeed with a coercion.  But it's much
               -- much simpler to require that such signatures have identical contexts
847
               checkTc (all isIdentityCoI cois)
Ian Lynagh's avatar
Ian Lynagh committed
848
849
                       (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
             }
850
\end{code}
851

852

853
@getTyVarsToGen@ decides what type variables to generalise over.
854
855
856
857
858
859
860
861

For a "restricted group" -- see the monomorphism restriction
for a definition -- we bind no dictionaries, and
remove from tyvars_to_gen any constrained type variables

*Don't* simplify dicts at this point, because we aren't going
to generalise over these dicts.  By the time we do simplify them
we may well know more.  For example (this actually came up)
Ian Lynagh's avatar
Ian Lynagh committed
862
863
        f :: Array Int Int
        f x = array ... xs where xs = [1,2,3,4,5]
864
865
866
867
868
We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
stuff.  If we simplify only at the f-binding (not the xs-binding)
we'll know that the literals are all Ints, and we can just produce
Int literals!

869
870
871
872
Find all the type variables involved in overloading, the
"constrained_tyvars".  These are the ones we *aren't* going to
generalise.  We must be careful about doing this:

873
 (a) If we fail to generalise a tyvar which is not actually
Ian Lynagh's avatar
Ian Lynagh committed
874
875
876
877
878
879
880
        constrained, then it will never, ever get bound, and lands
        up printed out in interface files!  Notorious example:
                instance Eq a => Eq (Foo a b) where ..
        Here, b is not constrained, even though it looks as if it is.
        Another, more common, example is when there's a Method inst in
        the LIE, whose type might very well involve non-overloaded
        type variables.
881
  [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
Ian Lynagh's avatar
Ian Lynagh committed
882
        the simple thing instead]
883

884
 (b) On the other hand, we mustn't generalise tyvars which are constrained,
Ian Lynagh's avatar
Ian Lynagh committed
885
886
        because we are going to pass on out the unmodified LIE, with those
        tyvars in it.  They won't be in scope if we've generalised them.
887
888
889
890
891

So we are careful, and do a complete simplification just to find the
constrained tyvars. We don't use any of the results, except to
find which tyvars are constrained.

892
893
894
Note [Polymorphic recursion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The game plan for polymorphic recursion in the code above is 
895

Ian Lynagh's avatar
Ian Lynagh committed
896
897
898
        * 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.
899

900
901
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:
902

Ian Lynagh's avatar
Ian Lynagh committed
903
904
        f :: Eq a => [a] -> [a]
        f xs = ...f...
905
906
907

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

Ian Lynagh's avatar
Ian Lynagh committed
908
909
910
        f = /\a -> \d::Eq a -> let f' = f a d
                               in
                               \ys:[a] -> ...f'...
911
912
913
914
915
916
917

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)

Ian Lynagh's avatar
Ian Lynagh committed
918
919
        ff :: [Int] -> [Int]
        ff = f Int dEqInt
920
921
922
923
924

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.

Ian Lynagh's avatar
Ian Lynagh committed
925
        ff = f Int dEqInt
926

Ian Lynagh's avatar
Ian Lynagh committed
927
           = let f' = f Int dEqInt in \ys. ...f'...
928

Ian Lynagh's avatar
Ian Lynagh committed
929
930
           = let f' = let f' = f Int dEqInt in \ys. ...f'...
                      in \ys. ...f'...
931
932

Etc.
933
934
935
936

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

937
938
939
940
941
942
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.
943

944
945
Then we get

Ian Lynagh's avatar
Ian Lynagh committed
946
947
948
949
        f = /\a -> \d::Eq a -> letrec
                                 fm = \ys:[a] -> ...fm...
                               in
                               fm
950

951
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
952
953
954
%*                                                                      *
                Signatures
%*                                                                      *
955
956
%************************************************************************

957
Type signatures are tricky.  See Note [Signature skolems] in TcType
958

959
960
961
962
963
964
965
966
967
@tcSigs@ checks the signatures for validity, and returns a list of
{\em freshly-instantiated} signatures.  That is, the types are already
split up, and have fresh type variables installed.  All non-type-signature
"RenamedSigs" are ignored.

The @TcSigInfo@ contains @TcTypes@ because they are unified with
the variable's type, and after that checked to see whether they've
been instantiated.

968
969
970
971
Note [Scoped tyvars]
~~~~~~~~~~~~~~~~~~~~
The -XScopedTypeVariables flag brings lexically-scoped type variables
into scope for any explicitly forall-quantified type variables:
Ian Lynagh's avatar
Ian Lynagh committed
972
973
        f :: forall a. a -> a
        f x = e
974
975
976
977
Then 'a' is in scope inside 'e'.

However, we do *not* support this 
  - For pattern bindings e.g
Ian Lynagh's avatar
Ian Lynagh committed
978
979
        f :: forall a. a->a
        (f,g) = e
980
981

  - For multiple function bindings, unless Opt_RelaxedPolyRec is on
Ian Lynagh's avatar
Ian Lynagh committed
982
983
984
985
        f :: forall a. a -> a
        f = g
        g :: forall b. b -> b
        g = ...f...
986
987
988
989
990
991
992
993
994
995
996
    Reason: we use mutable variables for 'a' and 'b', since they may
    unify to each other, and that means the scoped type variable would
    not stand for a completely rigid variable.

    Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec


Note [More instantiated than scoped]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There may be more instantiated type variables than lexically-scoped 
ones.  For example:
Ian Lynagh's avatar
Ian Lynagh committed
997
998
        type T a = forall b. b -> (a,b)
        f :: forall c. T c
999
1000
1001
1002
1003
1004
Here, the signature for f will have one scoped type variable, c,
but two instantiated type variables, c' and b'.  

We assume that the scoped ones are at the *front* of sig_tvs,
and remember the names from the original HsForAllTy in the TcSigFun.

1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
Note [Signature skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
When instantiating a type signature, we do so with either skolems or
SigTv meta-type variables depending on the use_skols boolean.  This
variable is set True when we are typechecking a single function
binding; and False for pattern bindings and a group of several
function bindings.

Reason: in the latter cases, the "skolems" can be unified together, 
        so they aren't properly rigid in the type-refinement sense.
NB: unless we are doing H98, each function with a sig will be done
    separately, even if it's mutually recursive, so use_skols will be True


Note [Only scoped tyvars are in the TyVarEnv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are careful to keep only the *lexically scoped* type variables in
the type environment.  Why?  After all, the renamer has ensured
that only legal occurrences occur, so we could put all type variables
into the type env.

But we want to check that two distinct lexically scoped type variables
do not map to the same internal type variable.  So we need to know which
the lexically-scoped ones are... and at the moment we do that by putting
only the lexically scoped ones into the environment.

Note [Instantiate sig with fresh variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's vital to instantiate a type signature with fresh variables.
For example:
      type T = forall a. [a] -> [a]
      f :: T; 
      f = g where { g :: T; g = <rhs> }

 We must not use the same 'a' from the defn of T at both places!!
(Instantiation is only necessary because of type synonyms.  Otherwise,
it's all cool; each signature has distinct type variables from the renamer.)
1042

1043
\begin{code}
1044
1045
1046
1047
1048
type SigFun = Name -> Maybe ([Name], SrcSpan)
         -- Maps a let-binder to the list of
         -- type variables brought into scope
         -- by its type signature, plus location
         -- Nothing => no type signature
1049

1050
mkSigFun :: [LSig Name] -> SigFun
1051
1052
1053
-- Search for a particular type signature
-- Precondition: the sigs are all type sigs
-- Precondition: no duplicates
1054
mkSigFun sigs = lookupNameEnv env
1055
  where
1056
    env = mkNameEnv (mapCatMaybes mk_pair sigs)
1057
1058
1059
    mk_pair (L loc (TypeSig (L _ name) lhs_ty)) = Just (name, (hsExplicitTvs lhs_ty, loc))
    mk_pair (L loc (IdSig id))                  = Just (idName id, ([], loc))
    mk_pair _                                   = Nothing    
Ian Lynagh's avatar
Ian Lynagh committed
1060
1061
1062
1063
        -- The scoped names are the ones explicitly mentioned
        -- in the HsForAll.  (There may be more in sigma_ty, because
        -- of nested type synonyms.  See Note [More instantiated than scoped].)
        -- See Note [Only scoped tyvars are in the TyVarEnv]
1064
1065
1066
1067
\end{code}

\begin{code}
tcTySig :: LSig Name -> TcM TcId
1068
tcTySig (L span (TypeSig (L _ name) ty))
Ian Lynagh's avatar
Ian Lynagh committed
1069
1070
1071
  = setSrcSpan span             $
    do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
        ; return (mkLocalId name sigma_ty) }
1072
1073
tcTySig (L _ (IdSig id))
  = return id
Ian Lynagh's avatar
Ian Lynagh committed
1074
tcTySig s = pprPanic "tcTySig" (ppr s)
1075
1076

-------------------
1077
1078
1079
1080
1081
1082
1083
1084
1085
tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun
tcInstSigs sig_fn bndrs
  = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs
       ; return (lookupNameEnv (mkNameEnv prs)) }
  where
    use_skols = isSingleton bndrs	-- See Note [Signature skolems]

tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo))
-- For use_skols :: Bool see Note [Signature skolems]
1086
--
1087
1088
1089
-- We must instantiate with fresh uniques, 
-- (see Note [Instantiate sig with fresh variables])
-- although we keep the same print-name.
1090

1091
1092
tcInstSig sig_fn use_skols name
  | Just (scoped_tvs, loc) <- sig_fn name
Ian Lynagh's avatar
Ian Lynagh committed
1093
1094
  = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into 
                                        -- scope when starting the binding group
1095
1096
1097
1098
        ; let poly_ty = idType poly_id
        ; (tvs, theta, tau) <- if use_skols
                               then tcInstType tcInstSkolTyVars poly_ty
                               else tcInstType tcInstSigTyVars  poly_ty
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
        ; let sig = TcSigInfo { sig_id = poly_id
	  	 	      , sig_scoped = scoped_tvs
                              , sig_tvs = tvs, sig_theta = theta, sig_tau = tau
                              , sig_loc = loc }
        ; return (Just (name, sig)) } 
  | otherwise
  = return Nothing

-------------------------------
data GeneralisationPlan 
  = NoGen		-- No generalisation, no AbsBinds
  | InferGen Bool	-- Implicit generalisation; there is an AbsBinds
    	     		--   True <=> apply the MR; generalise only unconstrained type vars
  | CheckGen TcSigInfo	-- Explicit generalisation; there is an AbsBinds

-- A consequence of the no-AbsBinds choice (NoGen) is that there is
-- no "polymorphic Id" and "monmomorphic Id"; there is just the one

instance Outputable GeneralisationPlan where
  ppr NoGen        = ptext (sLit "NoGen")
  ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b
  ppr (CheckGen s) = ptext (sLit "CheckGen") <+> ppr s

decideGeneralisationPlan 
   :: DynFlags -> TopLevelFlag -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
1125
  | bang_pat_binds                         = NoGen
1126
1127
1128
1129
  | mono_pat_binds                         = NoGen
  | Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
                                             then NoGen	      -- Optimise common case
                                             else CheckGen sig
1130
  | (xopt Opt_MonoLocalBinds dflags 
1131
1132
1133
      && isNotTopLevel top_lvl)      	   = NoGen
  | otherwise                              = InferGen mono_restriction

1134
  where
1135
1136
1137
1138
1139
1140
    bang_pat_binds = any (isBangHsBind . unLoc) binds
       -- Bang patterns must not be polymorphic,
       -- because we are going to force them
       -- See Trac #4498

    mono_pat_binds = xopt Opt_MonoPatBinds dflags
1141
                  && any (is_pat_bind . unLoc) binds
1142

1143
    mono_restriction = xopt Opt_MonomorphismRestriction dflags 
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
                    && any (restricted . unLoc) binds

    no_sig n = isNothing (sig_fn n)

    -- With OutsideIn, all nested bindings are monomorphic
    -- except a single function binding with a signature
    one_funbind_with_sig [L _ FunBind { fun_id = v }] = sig_fn (unLoc v)
    one_funbind_with_sig _                            = Nothing

    -- The Haskell 98 monomorphism resetriction
    restricted (PatBind {})                              = True
    restricted (VarBind { var_id = v })                  = no_sig v
    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
                                                           && no_sig (unLoc v)
    restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"

    restricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = True
    restricted_match _                                       = False
Ian Lynagh's avatar
Ian Lynagh committed
1162
1163
        -- No args => like a pattern binding
        -- Some args => a function binding
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183

    is_pat_bind (PatBind {}) = True
    is_pat_bind _            = False

-------------------
checkStrictBinds :: TopLevelFlag -> RecFlag
                 -> [LHsBind Name] -> [Id]
                 -> TcM ()
-- Check that non-overloaded unlifted bindings are
--      a) non-recursive,
--      b) not top level, 
--      c) not a multiple-binding group (more or less implied by (a))

checkStrictBinds top_lvl rec_group binds poly_ids
  | unlifted || bang_pat
  = do  { checkTc (isNotTopLevel top_lvl)
                  (strictBindErr "Top-level" unlifted binds)
        ; checkTc (isNonRec rec_group)
                  (strictBindErr "Recursive" unlifted binds)
        ; checkTc (isSingleton binds)
1184
                  (strictBindErr "Multiple" unlifted binds)
1185
1186
1187
1188
        -- This should be a checkTc, not a warnTc, but as of GHC 6.11
        -- the versions of alex and happy available have non-conforming
        -- templates, so the GHC build fails if it's an error:
        ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
1189
1190
1191